Session Stateful_Protocol_Composition_and_Typing

Theory Miscellaneous

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Miscellaneous.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹Miscellaneous Lemmata›
theory Miscellaneous
imports Main "HOL-Library.Sublist" "HOL-Library.While_Combinator"
begin

subsection ‹List: zip, filter, map›
lemma zip_arg_subterm_split:
  assumes "(x,y)  set (zip xs ys)"
  obtains xs' xs'' ys' ys'' where "xs = xs'@x#xs''" "ys = ys'@y#ys''" "length xs' = length ys'"
proof -
  from assms have "zs zs' vs vs'. xs = zs@x#zs'  ys = vs@y#vs'  length zs = length vs"
  proof (induction ys arbitrary: xs)
    case (Cons y' ys' xs)
    then obtain x' xs' where x': "xs = x'#xs'"
      by (metis empty_iff list.exhaust list.set(1) set_zip_leftD)
    show ?case
      by (cases "(x, y)  set (zip xs' ys')",
          metis xs = x'#xs' Cons.IH[of xs'] Cons_eq_appendI list.size(4),
          use Cons.prems x' in fastforce)
  qed simp
  thus ?thesis using that by blast
qed

lemma zip_arg_index:
  assumes "(x,y)  set (zip xs ys)"
  obtains i where "xs ! i = x" "ys ! i = y" "i < length xs" "i < length ys"
proof -
  obtain xs1 xs2 ys1 ys2 where "xs = xs1@x#xs2" "ys = ys1@y#ys2" "length xs1 = length ys1"
    using zip_arg_subterm_split[OF assms] by moura
  thus ?thesis using nth_append_length[of xs1 x xs2] nth_append_length[of ys1 y ys2] that by simp
qed

lemma filter_nth: "i < length (filter P xs)  P (filter P xs ! i)"
using nth_mem by force

lemma list_all_filter_eq: "list_all P xs  filter P xs = xs"
by (metis list_all_iff filter_True)

lemma list_all_filter_nil:
  assumes "list_all P xs"
    and "x. P x  ¬Q x"
  shows "filter Q xs = []"
using assms by (induct xs) simp_all

lemma list_all_concat: "list_all (list_all f) P  list_all f (concat P)"
by (induct P) auto

lemma map_upt_index_eq:
  assumes "j < length xs"
  shows "(map (λi. xs ! is i) [0..<length xs]) ! j = xs ! is j"
using assms by (simp add: map_nth)

lemma map_snd_list_insert_distrib:
  assumes "(i,p)  insert x (set xs). (i',p')  insert x (set xs). p = p'  i = i'"
  shows "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)"
using assms
proof (induction xs rule: List.rev_induct)
  case (snoc y xs)
  hence IH: "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)" by fastforce

  obtain iy py where y: "y = (iy,py)" by (metis surj_pair)
  obtain ix px where x: "x = (ix,px)" by (metis surj_pair)

  have "(ix,px)  insert x (set (y#xs))" "(iy,py)  insert x (set (y#xs))" using y x by auto
  hence *: "iy = ix" when "py = px" using that snoc.prems by auto

  show ?case
  proof (cases "px = py")
    case True
    hence "y = x" using * y x by auto
    thus ?thesis using IH by simp
  next
    case False
    hence "y  x" using y x by simp
    have "List.insert x (xs@[y]) = (List.insert x xs)@[y]"
    proof -
      have 1: "insert y (set xs) = set (xs@[y])" by simp
      have 2: "x  insert y (set xs)  x  set xs" using y  x by blast
      show ?thesis using 1 2 by (metis (no_types) List.insert_def append_Cons insertCI)
    qed
    thus ?thesis using IH y x False by (auto simp add: List.insert_def)
  qed
qed simp

lemma map_append_inv: "map f xs = ys@zs  vs ws. xs = vs@ws  map f vs = ys  map f ws = zs"
proof (induction xs arbitrary: ys zs)
  case (Cons x xs')
  note prems = Cons.prems
  note IH = Cons.IH

  show ?case
  proof (cases ys)
    case (Cons y ys') 
    then obtain vs' ws where *: "xs' = vs'@ws" "map f vs' = ys'" "map f ws = zs"
      using prems IH[of ys' zs] by auto
    hence "x#xs' = (x#vs')@ws" "map f (x#vs') = y#ys'" using Cons prems by force+
    thus ?thesis by (metis Cons *(3))
  qed (use prems in simp)
qed simp


subsection ‹List: subsequences›
lemma subseqs_set_subset:
  assumes "ys  set (subseqs xs)"
  shows "set ys  set xs"
using assms subseqs_powset[of xs] by auto

lemma subset_sublist_exists:
  "ys  set xs  zs. set zs = ys  zs  set (subseqs xs)"
proof (induction xs arbitrary: ys)
  case Cons thus ?case by (metis (no_types, lifting) Pow_iff imageE subseqs_powset) 
qed simp

lemma map_subseqs: "map (map f) (subseqs xs) = subseqs (map f xs)"
proof (induct xs)
  case (Cons x xs)
  have "map (Cons (f x)) (map (map f) (subseqs xs)) = map (map f) (map (Cons x) (subseqs xs))"
    by (induct "subseqs xs") auto
  thus ?case by (simp add: Let_def Cons)
qed simp

lemma subseqs_Cons:
  assumes "ys  set (subseqs xs)"
  shows "ys  set (subseqs (x#xs))"
by (metis assms Un_iff set_append subseqs.simps(2))

lemma subseqs_subset:
  assumes "ys  set (subseqs xs)"
  shows "set ys  set xs"
using assms by (metis Pow_iff image_eqI subseqs_powset)


subsection ‹List: prefixes, suffixes›
lemma suffix_Cons': "suffix [x] (y#ys)  suffix [x] ys  (y = x  ys = [])"
using suffix_Cons[of "[x]"] by auto

lemma prefix_Cons': "prefix (x#xs) (x#ys)  prefix xs ys"
by simp

lemma prefix_map: "prefix xs (map f ys)  zs. prefix zs ys  map f zs = xs"
using map_append_inv unfolding prefix_def by fast

lemma length_prefix_ex:
  assumes "n  length xs"
  shows "ys zs. xs = ys@zs  length ys = n"
  using assms
proof (induction n)
  case (Suc n)
  then obtain ys zs where IH: "xs = ys@zs" "length ys = n" by moura
  hence "length zs > 0" using Suc.prems(1) by auto
  then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc)
  hence "length (ys@[v]) = Suc n" using IH(2) by simp
  thus ?case using IH(1) v by (metis append.assoc append_Cons append_Nil)
qed simp

lemma length_prefix_ex':
  assumes "n < length xs"
  shows "ys zs. xs = ys@xs ! n#zs  length ys = n"
proof -
  obtain ys zs where xs: "xs = ys@zs" "length ys = n" using assms length_prefix_ex[of n xs] by moura
  hence "length zs > 0" using assms by auto
  then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc)
  hence "(ys@zs) ! n = v" using xs by auto
  thus ?thesis using v xs by auto
qed

lemma length_prefix_ex2:
  assumes "i < length xs" "j < length xs" "i < j"
  shows "ys zs vs. xs = ys@xs ! i#zs@xs ! j#vs  length ys = i  length zs = j - i - 1"
by (smt assms length_prefix_ex' nth_append append.assoc append.simps(2) add_diff_cancel_left'
        diff_Suc_1 length_Cons length_append)


subsection ‹List: products›
lemma product_lists_Cons:
  "x#xs  set (product_lists (y#ys))  (xs  set (product_lists ys)  x  set y)"
by auto

lemma product_lists_in_set_nth:
  assumes "xs  set (product_lists ys)"
  shows "i<length ys. xs ! i  set (ys ! i)"
proof -
  have 0: "length ys = length xs" using assms(1) by (simp add: in_set_product_lists_length)
  thus ?thesis using assms
  proof (induction ys arbitrary: xs)
    case (Cons y ys)
    obtain x xs' where xs: "xs = x#xs'" using Cons.prems(1) by (metis length_Suc_conv)
    hence "xs'  set (product_lists ys)  i<length ys. xs' ! i  set (ys ! i)"
          "length ys = length xs'" "x#xs'  set (product_lists (y#ys))"
      using Cons by simp_all
    thus ?case using xs product_lists_Cons[of x xs' y ys] by (simp add: nth_Cons')
  qed simp
qed

lemma product_lists_in_set_nth':
  assumes "i<length xs. ys ! i  set (xs ! i)"
    and "length xs = length ys"
  shows "ys  set (product_lists xs)"
using assms
proof (induction xs arbitrary: ys)
  case (Cons x xs)
  obtain y ys' where ys: "ys = y#ys'" using Cons.prems(2) by (metis length_Suc_conv)
  hence "ys'  set (product_lists xs)" "y  set x" "length xs = length ys'"
    using Cons by fastforce+
  thus ?case using ys product_lists_Cons[of y ys' x xs] by (simp add: nth_Cons')
qed simp


subsection ‹Other Lemmata›
lemma inv_set_fset: "finite M  set (inv set M) = M"
unfolding inv_def by (metis (mono_tags) finite_list someI_ex)

lemma lfp_eqI':
  assumes "mono f"
    and "f C = C"
    and "X  Pow C. f X = X  X = C"
  shows "lfp f = C"
by (metis PowI assms lfp_lowerbound lfp_unfold subset_refl)

lemma lfp_while':
  fixes f::"'a set  'a set" and M::"'a set"
  defines "N  while (λA. f A  A) f {}"
  assumes f_mono: "mono f"
    and N_finite: "finite N"
    and N_supset: "f N  N"
  shows "lfp f = N"
proof -
  have *: "f X  N" when "X  N" for X using N_supset monoD[OF f_mono that] by blast
  show ?thesis
    using lfp_while[OF f_mono * N_finite]
    by (simp add: N_def)
qed

lemma lfp_while'':
  fixes f::"'a set  'a set" and M::"'a set"
  defines "N  while (λA. f A  A) f {}"
  assumes f_mono: "mono f"
    and lfp_finite: "finite (lfp f)"
  shows "lfp f = N"
proof -
  have *: "f X  lfp f" when "X  lfp f" for X
    using lfp_fixpoint[OF f_mono] monoD[OF f_mono that]
    by blast
  show ?thesis
    using lfp_while[OF f_mono * lfp_finite]
    by (simp add: N_def)
qed

lemma preordered_finite_set_has_maxima:
  assumes "finite A" "A  {}"
  shows "a::'a::{preorder}  A. b  A. ¬(a < b)"
using assms 
proof (induction A rule: finite_induct)
  case (insert a A) thus ?case
    by (cases "A = {}", simp, metis insert_iff order_trans less_le_not_le)
qed simp

lemma partition_index_bij:
  fixes n::nat
  obtains I k where
    "bij_betw I {0..<n} {0..<n}" "k  n"
    "i. i < k  P (I i)"
    "i. k  i  i < n  ¬(P (I i))"
proof -
  define A where "A = filter P [0..<n]"
  define B where "B = filter (λi. ¬P i) [0..<n]"
  define k where "k = length A"
  define I where "I = (λn. (A@B) ! n)"

  note defs = A_def B_def k_def I_def
  
  have k1: "k  n" by (metis defs(1,3) diff_le_self dual_order.trans length_filter_le length_upt)

  have "i < k  P (A ! i)" for i by (metis defs(1,3) filter_nth)
  hence k2: "i < k  P ((A@B) ! i)" for i by (simp add: defs nth_append) 

  have "i < length B  ¬(P (B ! i))" for i by (metis defs(2) filter_nth)
  hence "i < length B  ¬(P ((A@B) ! (k + i)))" for i using k_def by simp 
  hence "k  i  i < k + length B  ¬(P ((A@B) ! i))" for i
    by (metis add.commute add_less_imp_less_right le_add_diff_inverse2)
  hence k3: "k  i  i < n  ¬(P ((A@B) ! i))" for i by (simp add: defs sum_length_filter_compl)

  have *: "length (A@B) = n" "set (A@B) = {0..<n}" "distinct (A@B)"
    by (metis defs(1,2) diff_zero length_append length_upt sum_length_filter_compl)
       (auto simp add: defs)

  have I: "bij_betw I {0..<n} {0..<n}"
  proof (intro bij_betwI')
    fix x y show "x  {0..<n}  y  {0..<n}  (I x = I y) = (x = y)"
      by (metis *(1,3) defs(4) nth_eq_iff_index_eq atLeastLessThan_iff)
  next
    fix x show "x  {0..<n}  I x  {0..<n}"
      by (metis *(1,2) defs(4) atLeastLessThan_iff nth_mem)
  next
    fix y show "y  {0..<n}  x  {0..<n}. y = I x"
      by (metis * defs(4) atLeast0LessThan distinct_Ex1 lessThan_iff)
  qed

  show ?thesis using k1 k2 k3 I that by (simp add: defs)
qed

lemma finite_lists_length_eq':
  assumes "x. x  set xs  finite {y. P x y}"
  shows "finite {ys. length xs = length ys  (y  set ys. x  set xs. P x y)}"
proof -
  define Q where "Q  λys. y  set ys. x  set xs. P x y"
  define M where "M  {y. x  set xs. P x y}"

  have 0: "finite M" using assms unfolding M_def by fastforce

  have "Q ys  set ys  M"
       "(Q ys  length ys = length xs)  (length xs = length ys  Q ys)"
    for ys
    unfolding Q_def M_def by auto
  thus ?thesis
    using finite_lists_length_eq[OF 0, of "length xs"]
    unfolding Q_def by presburger
qed

lemma trancl_eqI:
  assumes "(a,b)  A. (c,d)  A. b = c  (a,d)  A"
  shows "A = A+"
proof
  show "A+  A"
  proof
    fix x assume x: "x  A+"
    then obtain a b where ab: "x = (a,b)" by (metis surj_pair)
    hence "(a,b)  A+" using x by metis
    hence "(a,b)  A" using assms by (induct rule: trancl_induct) auto
    thus "x  A" using ab by metis
  qed
qed auto

lemma trancl_eqI':
  assumes "(a,b)  A. (c,d)  A. b = c  a  d  (a,d)  A"
    and "(a,b)  A. a  b"
  shows "A = {(a,b)  A+. a  b}"
proof
  show "{(a,b)  A+. a  b}  A"
  proof
    fix x assume x: "x  {(a,b)  A+. a  b}"
    then obtain a b where ab: "x = (a,b)" by (metis surj_pair)
    hence "(a,b)  A+" "a  b" using x by blast+
    hence "(a,b)  A"
    proof (induction rule: trancl_induct)
      case base thus ?case by blast
    next
      case step thus ?case using assms(1) by force
    qed
    thus "x  A" using ab by metis
  qed
qed (use assms(2) in auto)

lemma distinct_concat_idx_disjoint:
  assumes xs: "distinct (concat xs)"
    and ij: "i < length xs" "j < length xs" "i < j"
  shows "set (xs ! i)  set (xs ! j) = {}"
proof -
  obtain ys zs vs where ys: "xs = ys@xs ! i#zs@xs ! j#vs" "length ys = i" "length zs = j - i - 1"
    using length_prefix_ex2[OF ij] by moura
  thus ?thesis
    using xs concat_append[of "ys@xs ! i#zs" "xs ! j#vs"]
          distinct_append[of "concat (ys@xs ! i#zs)" "concat (xs ! j#vs)"]
    by auto
qed

lemma remdups_ex2:
  "length (remdups xs) > 1  a  set xs. b  set xs. a  b"
by (metis distinct_Ex1 distinct_remdups less_trans nth_mem set_remdups zero_less_one zero_neq_one)

lemma trancl_minus_refl_idem:
  defines "cl  λts. {(a,b)  ts+. a  b}"
  shows "cl (cl ts) = cl ts"
proof -
  have 0: "(ts+)+ = ts+" "cl ts  ts+" "(cl ts)+  (ts+)+"
  proof -
    show "(ts+)+ = ts+" "cl ts  ts+" unfolding cl_def by auto
    thus "(cl ts)+  (ts+)+" using trancl_mono[of _ "cl ts" "ts+"] by blast
  qed

  have 1: "t  cl (cl ts)" when t: "t  cl ts" for t
    using t 0 unfolding cl_def by fast

  have 2: "t  cl ts" when t: "t  cl (cl ts)" for t
  proof -
    obtain a b where ab: "t = (a,b)" by (metis surj_pair)
    have "t  (cl ts)+" and a_neq_b: "a  b" using t unfolding cl_def ab by force+
    hence "t  ts+" using 0 by blast
    thus ?thesis using a_neq_b unfolding cl_def ab by blast
  qed

  show ?thesis using 1 2 by blast
qed


subsection ‹Infinite Paths in Relations as Mappings from Naturals to States›
context
begin

private fun rel_chain_fun::"nat  'a  'a  ('a × 'a) set  'a" where
  "rel_chain_fun 0 x _ _ = x"
| "rel_chain_fun (Suc i) x y r = (if i = 0 then y else SOME z. (rel_chain_fun i x y r, z)  r)"

lemma infinite_chain_intro:
  fixes r::"('a × 'a) set"
  assumes "(a,b)  r. c. (b,c)  r" "r  {}"
  shows "f. i::nat. (f i, f (Suc i))  r"
proof -
  from assms(2) obtain a b where "(a,b)  r" by auto

  let ?P = "λi. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r)  r"
  let ?Q = "λi. z. (rel_chain_fun i a b r, z)  r"

  have base: "?P 0" using (a,b)  r by auto

  have step: "?P (Suc i)" when i: "?P i" for i
  proof -
    have "?Q (Suc i)" using assms(1) i by auto
    thus ?thesis using someI_ex[OF ?Q (Suc i)] by auto
  qed

  have "i::nat. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r)  r"
    using base step nat_induct[of ?P] by simp
  thus ?thesis by fastforce
qed

end

lemma infinite_chain_intro':
  fixes r::"('a × 'a) set"
  assumes base: "b. (x,b)  r" and step: "b. (x,b)  r+  (c. (b,c)  r)" 
  shows "f. i::nat. (f i, f (Suc i))  r"
proof -
  let ?s = "{(a,b)  r. a = x  (x,a)  r+}"

  have "?s  {}" using base by auto

  have "c. (b,c)  ?s" when ab: "(a,b)  ?s" for a b
  proof (cases "a = x")
    case False
    hence "(x,a)  r+" using ab by auto
    hence "(x,b)  r+" using (a,b)  ?s by auto
    thus ?thesis using step by auto
  qed (use ab step in auto)
  hence "f. i. (f i, f (Suc i))  ?s" using infinite_chain_intro[of ?s] ?s  {} by blast
  thus ?thesis by auto
qed

lemma infinite_chain_mono:
  assumes "S  T" "f. i::nat. (f i, f (Suc i))  S"
  shows "f. i::nat. (f i, f (Suc i))  T"
using assms by auto

end

Theory Messages

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Messages.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹Protocol Messages as (First-Order) Terms›

theory Messages
  imports Miscellaneous "First_Order_Terms.Term"
begin

subsection ‹Term-related definitions: subterms and free variables›
abbreviation "the_Fun  un_Fun1"
lemmas the_Fun_def = un_Fun1_def

fun subterms::"('a,'b) term  ('a,'b) terms" where
  "subterms (Var x) = {Var x}"
| "subterms (Fun f T) = {Fun f T}  (t  set T. subterms t)"

abbreviation subtermeq (infix "" 50) where "t'  t  (t'  subterms t)"
abbreviation subterm (infix "" 50) where "t'  t  (t'  t  t'  t)"

abbreviation "subtermsset M  (subterms ` M)"
abbreviation subtermeqset (infix "set" 50) where "t set M  (t  subtermsset M)"

abbreviation fv where "fv  vars_term"
lemmas fv_simps = term.simps(17,18)

fun fvset where "fvset M = (fv ` M)"

abbreviation fvpair where "fvpair p  case p of (t,t')  fv t  fv t'"

fun fvpairs where "fvpairs F = (fvpair ` set F)"

abbreviation ground where "ground M  fvset M = {}"


subsection ‹Variants that return lists insteads of sets›
fun fv_list where
  "fv_list (Var x) = [x]"
| "fv_list (Fun f T) = concat (map fv_list T)"

definition fv_listpairs where
  "fv_listpairs F  concat (map (λ(t,t'). fv_list t@fv_list t') F)"

fun subterms_list::"('a,'b) term  ('a,'b) term list" where
  "subterms_list (Var x) = [Var x]"
| "subterms_list (Fun f T) = remdups (Fun f T#concat (map subterms_list T))"

lemma fv_list_is_fv: "fv t = set (fv_list t)"
by (induct t) auto

lemma fv_listpairs_is_fvpairs: "fvpairs F = set (fv_listpairs F)"
by (induct F) (auto simp add: fv_list_is_fv fv_listpairs_def)

lemma subterms_list_is_subterms: "subterms t = set (subterms_list t)"
by (induct t) auto


subsection ‹The subterm relation defined as a function›
fun subterm_of where
  "subterm_of t (Var y) = (t = Var y)"
| "subterm_of t (Fun f T) = (t = Fun f T  list_ex (subterm_of t) T)"

lemma subterm_of_iff_subtermeq[code_unfold]: "t  t' = subterm_of t t'"
proof (induction t')
  case (Fun f T) thus ?case
  proof (cases "t = Fun f T")
    case False thus ?thesis
      using Fun.IH subterm_of.simps(2)[of t f T]
      unfolding list_ex_iff by fastforce
  qed simp
qed simp

lemma subterm_of_ex_set_iff_subtermeqset[code_unfold]: "t set M = (t'  M. subterm_of t t')"
using subterm_of_iff_subtermeq by blast


subsection ‹The subterm relation is a partial order on terms›

interpretation "term": ordering "(⊑)" "(⊏)"
proof
  show "s  s" for s :: "('a,'b) term"
    by (induct s rule: subterms.induct) auto

  show trans: "s  t  t  u  s  u" for s t u :: "('a,'b) term"
    by (induct u rule: subterms.induct) auto

  show "s  t  t  s  s = t" for s t :: "('a,'b) term"
  proof (induction s arbitrary: t rule: subterms.induct[case_names Var Fun])
    case (Fun f T)
    { assume 0: "t  Fun f T"
      then obtain u::"('a,'b) term" where u: "u  set T" "t  u" using Fun.prems(2) by auto
      hence 1: "Fun f T  u" using trans[OF Fun.prems(1)] by simp
   
      have 2: "u  Fun f T"
        by (cases u) (use u(1) in force, use u(1) subterms.simps(2)[of f T] in fastforce)
      hence 3: "u = Fun f T" using Fun.IH[OF u(1) _ 1] by simp

      have "u  t" using trans[OF 2 Fun.prems(1)] by simp
      hence 4: "u = t" using Fun.IH[OF u(1) _ u(2)] by simp
  
      have "t = Fun f T" using 3 4 by simp
      hence False using 0 by simp
    }
    thus ?case by auto
  qed simp
  show s  t  s  t for s t :: "('a,'b) term" ..
qed

interpretation "term": order "(⊑)" "(⊏)"
  by (rule ordering_orderI) (fact term.ordering_axioms)

subsection ‹Lemmata concerning subterms and free variables›
lemma fv_listpairs_append: "fv_listpairs (F@G) = fv_listpairs F@fv_listpairs G"
by (simp add: fv_listpairs_def)

lemma distinct_fv_list_idx_fv_disjoint:
  assumes t: "distinct (fv_list t)" "Fun f T  t"
    and ij: "i < length T" "j < length T" "i < j"
  shows "fv (T ! i)  fv (T ! j) = {}"
using t
proof (induction t rule: fv_list.induct)
  case (2 g S)
  have "distinct (fv_list s)" when s: "s  set S" for s
    by (metis (no_types, lifting) s "2.prems"(1) concat_append distinct_append 
          map_append split_list fv_list.simps(2) concat.simps(2) list.simps(9))
  hence IH: "fv (T ! i)  fv (T ! j) = {}"
    when s: "s  set S" "Fun f T  s" for s
    using "2.IH" s by blast

  show ?case
  proof (cases "Fun f T = Fun g S")
    case True
    define U where "U  map fv_list T"

    have a: "distinct (concat U)"
      using "2.prems"(1) True unfolding U_def by auto
    
    have b: "i < length U" "j < length U"
      using ij(1,2) unfolding U_def by simp_all

    show ?thesis
      using b distinct_concat_idx_disjoint[OF a b ij(3)]
            fv_list_is_fv[of "T ! i"] fv_list_is_fv[of "T ! j"]
      unfolding U_def by force
  qed (use IH "2.prems"(2) in auto)
qed force

lemmas subtermeqI'[intro] = term.eq_refl

lemma subtermeqI''[intro]: "t  set T  t  Fun f T"
by force

lemma finite_fv_set[intro]: "finite M  finite (fvset M)"
by auto

lemma finite_fun_symbols[simp]: "finite (funs_term t)"
by (induct t) simp_all

lemma fv_set_mono: "M  N  fvset M  fvset N"
by auto

lemma subtermsset_mono: "M  N  subtermsset M  subtermsset N"
by auto

lemma ground_empty[simp]: "ground {}"
by simp

lemma ground_subset: "M  N  ground N  ground M"
by auto

lemma fv_map_fv_set: "(set (map fv L)) = fvset (set L)"
by (induct L) auto

lemma fvset_union: "fvset (M  N) = fvset M  fvset N"
by auto

lemma finite_subset_Union:
  fixes A::"'a set" and f::"'a  'b set"
  assumes "finite (a  A. f a)"
  shows "B. finite B  B  A  (b  B. f b) = (a  A. f a)"
by (metis assms eq_iff finite_subset_image finite_UnionD)

lemma inv_set_fv: "finite M  (set (map fv (inv set M))) = fvset M"
using fv_map_fv_set[of "inv set M"] inv_set_fset by auto

lemma ground_subterm: "fv t = {}  t'  t  fv t' = {}" by (induct t) auto

lemma empty_fv_not_var: "fv t = {}  t  Var x" by auto

lemma empty_fv_exists_fun: "fv t = {}  f X. t = Fun f X" by (cases t) auto

lemma vars_iff_subtermeq: "x  fv t  Var x  t" by (induct t) auto

lemma vars_iff_subtermeq_set: "x  fvset M  Var x  subtermsset M"
using vars_iff_subtermeq[of x] by auto

lemma vars_if_subtermeq_set: "Var x  subtermsset M  x  fvset M"
by (metis vars_iff_subtermeq_set)

lemma subtermeq_set_if_vars: "x  fvset M  Var x  subtermsset M"
by (metis vars_iff_subtermeq_set)

lemma vars_iff_subterm_or_eq: "x  fv t  Var x  t  Var x = t"
by (induct t) (auto simp add: vars_iff_subtermeq)

lemma var_is_subterm: "x  fv t  Var x  subterms t"
by (simp add: vars_iff_subtermeq)

lemma subterm_is_var: "Var x  subterms t  x  fv t"
by (simp add: vars_iff_subtermeq)

lemma no_var_subterm: "¬t  Var v" by auto

lemma fun_if_subterm: "t  u  f X. u = Fun f X" by (induct u) simp_all

lemma subtermeq_vars_subset: "M  N  fv M  fv N" by (induct N) auto

lemma fv_subterms[simp]: "fvset (subterms t) = fv t"
by (induct t) auto

lemma fv_subterms_set[simp]: "fvset (subtermsset M) = fvset M"
using subtermeq_vars_subset by auto

lemma fv_subset: "t  M  fv t  fvset M"
by auto

lemma fv_subset_subterms: "t  subtermsset M  fv t  fvset M"
using fv_subset fv_subterms_set by metis

lemma subterms_finite[simp]: "finite (subterms t)" by (induction rule: subterms.induct) auto

lemma subterms_union_finite: "finite M  finite (t  M. subterms t)"
by (induction rule: subterms.induct) auto

lemma subterms_subset: "t'  t  subterms t'  subterms t"
by (induction rule: subterms.induct) auto

lemma subterms_subset_set: "M  subterms t  subtermsset M  subterms t"
by (metis SUP_least contra_subsetD subterms_subset)

lemma subset_subterms_Union[simp]: "M  subtermsset M" by auto

lemma in_subterms_Union: "t  M  t  subtermsset M" using subset_subterms_Union by blast

lemma in_subterms_subset_Union: "t  subtermsset M  subterms t  subtermsset M"
using subterms_subset by auto

lemma subterm_param_split: 
  assumes "t  Fun f X"
  shows "pre x suf. t  x  X = pre@x#suf"
proof -
  obtain x where "t  x" "x  set X" using assms by auto
  then obtain pre suf where "X = pre@x#suf" "x  set pre  x  set suf"
    by (meson split_list_first split_list_last)
  thus ?thesis using t  x by auto
qed

lemma ground_iff_no_vars: "ground (M::('a,'b) terms)  (v. Var v  (m  M. subterms m))"
proof
  assume "ground M"
  hence "v. m  M. v  fv m" by auto
  hence "v. m  M. Var v  subterms m" by (simp add: vars_iff_subtermeq)
  thus "(v. Var v  (m  M. subterms m))" by simp
next
  assume no_vars: "v. Var v  (m  M. subterms m)"
  moreover
  { assume "¬ground M"
    then obtain v and m::"('a,'b) term" where "m  M" "fv m  {}" "v  fv m" by auto
    hence "Var v  (subterms m)" by (simp add: vars_iff_subtermeq)
    hence "v. Var v  (t  M. subterms t)" using m  M by auto
    hence False using no_vars by simp
  }
  ultimately show "ground M" by blast
qed

lemma index_Fun_subterms_subset[simp]: "i < length T  subterms (T ! i)  subterms (Fun f T)"
by auto

lemma index_Fun_fv_subset[simp]: "i < length T  fv (T ! i)  fv (Fun f T)"
using subtermeq_vars_subset by fastforce

lemma subterms_union_ground:
  assumes "ground M"
  shows "ground (subtermsset M)"
proof -
  { fix t assume "t  M"
    hence "fv t = {}"
      using ground_iff_no_vars[of M] assms
      by auto
    hence "t'  subterms t. fv t' = {}" using subtermeq_vars_subset[of _ t] by simp
    hence "ground (subterms t)" by auto
  }
  thus ?thesis by auto
qed

lemma Var_subtermeq: "t  Var v  t = Var v" by simp

lemma subtermeq_imp_funs_term_subset: "s  t  funs_term s  funs_term t"
by (induct t arbitrary: s) auto

lemma subterms_const: "subterms (Fun f []) = {Fun f []}" by simp

lemma subterm_subtermeq_neq: "t  u; u  v  t  v"
by (metis term.eq_iff)

lemma subtermeq_subterm_neq: "t  u; u  v  t  v"
by (metis term.eq_iff)

lemma subterm_size_lt: "x  y  size x < size y"
using not_less_eq size_list_estimation by (induct y, simp, fastforce)

lemma in_subterms_eq: "x  subterms y; y  subterms x  subterms x = subterms y"
using term.antisym by auto

lemma Fun_gt_params: "Fun f X  (x  set X. subterms x)"
proof -
  have "size_list size X < size (Fun f X)" by simp
  hence "Fun f X  set X" by (meson less_not_refl size_list_estimation) 
  hence "x  set X. Fun f X  subterms x  x  subterms (Fun f X)"
    by (metis term.antisym[of "Fun f X" _])
  moreover have "x  set X. x  subterms (Fun f X)" by fastforce
  ultimately show ?thesis by auto
qed

lemma params_subterms[simp]: "set X  subterms (Fun f X)" by auto

lemma params_subterms_Union[simp]: "subtermsset (set X)  subterms (Fun f X)" by auto

lemma Fun_subterm_inside_params: "t  Fun f X  t  (x  (set X). subterms x)"
using Fun_gt_params by fastforce

lemma Fun_param_is_subterm: "x  set X  x  Fun f X"
using Fun_subterm_inside_params by fastforce

lemma Fun_param_in_subterms: "x  set X  x  subterms (Fun f X)"
using Fun_subterm_inside_params by fastforce

lemma Fun_not_in_param: "x  set X  ¬Fun f X  x"
using term.antisym by fast

lemma Fun_ex_if_subterm: "t  s  f T. Fun f T  s  t  set T"
proof (induction s)
  case (Fun f T)
  then obtain s' where s': "s'  set T" "t  s'" by auto
  show ?case
  proof (cases "t = s'")
    case True thus ?thesis using s' by blast
  next
    case False
    thus ?thesis
      using Fun.IH[OF s'(1)] s'(2) term.order_trans[OF _ Fun_param_in_subterms[OF s'(1), of f]]
      by metis
  qed
qed simp

lemma const_subterm_obtain:
  assumes "fv t = {}"
  obtains c where "Fun c []  t"
using assms
proof (induction t)
  case (Fun f T) thus ?case by (cases "T = []") force+
qed simp

lemma const_subterm_obtain': "fv t = {}  c. Fun c []  t"
by (metis const_subterm_obtain)

lemma subterms_singleton:
  assumes "(v. t = Var v)  (f. t = Fun f [])"
  shows "subterms t = {t}"
using assms by (cases t) auto

lemma subtermeq_Var_const:
  assumes "s  t"
  shows "t = Var v  s = Var v" "t = Fun f []  s = Fun f []"
using assms by fastforce+

lemma subterms_singleton':
  assumes "subterms t = {t}"
  shows "(v. t = Var v)  (f. t = Fun f [])"
proof (cases t)
  case (Fun f T)
  { fix s S assume "T = s#S"
    hence "s  subterms t" using Fun by auto
    hence "s = t" using assms by auto
    hence False
      using Fun_param_is_subterm[of s "s#S" f] T = s#S Fun
      by auto
  }
  hence "T = []" by (cases T) auto
  thus ?thesis using Fun by simp
qed (simp add: assms)

lemma funs_term_subterms_eq[simp]:
  "(s  subterms t. funs_term s) = funs_term t" 
  "(s  subtermsset M. funs_term s) = (funs_term ` M)"
proof -
  show "t. (funs_term ` subterms t) = funs_term t"
    using term.order_refl subtermeq_imp_funs_term_subset by blast
  thus "(funs_term ` (subtermsset M)) = (funs_term ` M)" by force
qed

lemmas subtermI'[intro] = Fun_param_is_subterm

lemma funs_term_Fun_subterm: "f  funs_term t  T. Fun f T  subterms t"
proof (induction t)
  case (Fun g T)
  hence "f = g  (s  set T. f  funs_term s)" by simp
  thus ?case
  proof
    assume "s  set T. f  funs_term s"
    then obtain s where "s  set T" "T. Fun f T  subterms s" using Fun.IH by auto
    thus ?thesis by auto
  qed (auto simp add: Fun)
qed simp

lemma funs_term_Fun_subterm': "Fun f T  subterms t  f  funs_term t"
by (induct t) auto

lemma zip_arg_subterm:
  assumes "(s,t)  set (zip X Y)"
  shows "s  Fun f X" "t  Fun g Y"
proof -
  from assms have *: "s  set X" "t  set Y" by (meson in_set_zipE)+
  show "s  Fun f X" by (metis Fun_param_is_subterm[OF *(1)])
  show "t  Fun g Y" by (metis Fun_param_is_subterm[OF *(2)])
qed

lemma fv_disj_Fun_subterm_param_cases:
  assumes "fv t  X = {}" "Fun f T  subterms t"
  shows "T = []  (sset T. s  Var ` X)"
proof (cases T)
  case (Cons s S)
  hence "s  subterms t"
    using assms(2) term.order_trans[of _ "Fun f T" t]
    by auto
  hence "fv s  X = {}" using assms(1) fv_subterms by force
  thus ?thesis using Cons by auto
qed simp

lemma fv_eq_FunI:
  assumes "length T = length S" "i. i < length T  fv (T ! i) = fv (S ! i)"
  shows "fv (Fun f T) = fv (Fun g S)"
using assms
proof (induction T arbitrary: S)
  case (Cons t T S')
  then obtain s S where S': "S' = s#S" by (cases S') simp_all
  thus ?case using Cons by fastforce
qed simp

lemma fv_eq_FunI':
  assumes "length T = length S" "i. i < length T  x  fv (T ! i)  x  fv (S ! i)"
  shows "x  fv (Fun f T)  x  fv (Fun g S)"
using assms
proof (induction T arbitrary: S)
  case (Cons t T S')
  then obtain s S where S': "S' = s#S" by (cases S') simp_all
  thus ?case using Cons by fastforce
qed simp

lemma finite_fvpairs[simp]: "finite (fvpairs x)" by auto

lemma fvpairs_Nil[simp]: "fvpairs [] = {}" by simp

lemma fvpairs_singleton[simp]: "fvpairs [(t,s)] = fv t  fv s" by simp

lemma fvpairs_Cons: "fvpairs ((s,t)#F) = fv s  fv t  fvpairs F" by simp

lemma fvpairs_append: "fvpairs (F@G) = fvpairs F  fvpairs G" by simp

lemma fvpairs_mono: "set M  set N  fvpairs M  fvpairs N" by auto

lemma fvpairs_inI[intro]:
  "f  set F  x  fvpair f  x  fvpairs F"
  "f  set F  x  fv (fst f)  x  fvpairs F"
  "f  set F  x  fv (snd f)  x  fvpairs F"
  "(t,s)  set F  x  fv t  x  fvpairs F"
  "(t,s)  set F  x  fv s  x  fvpairs F"
using UN_I by fastforce+

lemma fvpairs_cons_subset: "fvpairs F  fvpairs (f#F)"
by auto


subsection ‹Other lemmata›
lemma nonvar_term_has_composed_shallow_term:
  fixes t::"('f,'v) term"
  assumes "¬(x. t = Var x)"
  shows "f T. Fun f T  t  (s  set T. (c. s = Fun c [])  (x. s = Var x))"
proof -
  let ?Q = "λS. s  set S. (c. s = Fun c [])  (x. s = Var x)"
  let ?P = "λt. g S. Fun g S  t  ?Q S"
  { fix t::"('f,'v) term"
    have "(x. t = Var x)  ?P t"
    proof (induction t)
      case (Fun h R) show ?case
      proof (cases "R = []  (r  set R. x. r = Var x)")
        case False
        then obtain r g S where "r  set R" "?P r" "Fun g S  r" "?Q S" using Fun.IH by fast
        thus ?thesis by auto
      qed force
    qed simp
  } thus ?thesis using assms by blast
qed

end

Theory More_Unification

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*
Based on src/HOL/ex/Unification.thy packaged with Isabelle/HOL 2015 having the following license:

ISABELLE COPYRIGHT NOTICE, LICENCE AND DISCLAIMER.

Copyright (c) 1986-2015,
  University of Cambridge,
  Technische Universitaet Muenchen,
  and contributors.

  All rights reserved.

Redistribution and use in source and binary forms, with or without 
modification, are permitted provided that the following conditions are 
met:

* Redistributions of source code must retain the above copyright 
notice, this list of conditions and the following disclaimer.

* Redistributions in binary form must reproduce the above copyright 
notice, this list of conditions and the following disclaimer in the 
documentation and/or other materials provided with the distribution.

* Neither the name of the University of Cambridge or the Technische
Universitaet Muenchen nor the names of their contributors may be used
to endorse or promote products derived from this software without
specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)


(*  Title:      More_Unification.thy
    Author:     Andreas Viktor Hess, DTU

    Originally based on src/HOL/ex/Unification.thy (Isabelle/HOL 2015) by:
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Author:     Konrad Slind, TUM & Cambridge University Computer Laboratory
    Author:     Alexander Krauss, TUM
*)

section ‹Definitions and Properties Related to Substitutions and Unification›

theory More_Unification
  imports Messages "First_Order_Terms.Unification"
begin

subsection ‹Substitutions›

abbreviation subst_apply_list (infix "list" 51) where
  "T list θ  map (λt. t  θ) T"  

abbreviation subst_apply_pair (infixl "p" 60) where
  "d p θ  (case d of (t,t')  (t  θ, t'  θ))"

abbreviation subst_apply_pair_set (infixl "pset" 60) where
  "M pset θ  (λd. d p θ) ` M"

definition subst_apply_pairs (infix "pairs" 51) where
  "F pairs θ  map (λf. f p θ) F"

abbreviation subst_more_general_than (infixl "" 50) where
  "σ  θ  γ. θ = σ s γ"

abbreviation subst_support (infix "supports" 50) where
  "θ supports δ  (x. θ x  δ = δ x)"

abbreviation rm_var where
  "rm_var v s  s(v := Var v)"

abbreviation rm_vars where
  "rm_vars vs σ  (λv. if v  vs then Var v else σ v)"

definition subst_elim where
  "subst_elim σ v  t. v  fv (t  σ)"

definition subst_idem where
  "subst_idem s  s s s = s"

lemma subst_support_def: "θ supports τ  τ = θ s τ"
unfolding subst_compose_def by metis

lemma subst_supportD: "θ supports δ  θ  δ"
using subst_support_def by auto

lemma rm_vars_empty[simp]: "rm_vars {} s = s" "rm_vars (set []) s = s"
by simp_all

lemma rm_vars_singleton: "rm_vars {v} s = rm_var v s"
by auto

lemma subst_apply_terms_empty: "M set Var = M"
by simp

lemma subst_agreement: "(t  r = t  s)  (v  fv t. Var v  r = Var v  s)"
by (induct t) auto

lemma repl_invariance[dest?]: "v  fv t  t  s(v := u) = t  s"
by (simp add: subst_agreement)

lemma subst_idx_map:
  assumes "i  set I. i < length T"
  shows "(map ((!) T) I) list δ = map ((!) (map (λt. t  δ) T)) I"
using assms by auto

lemma subst_idx_map':
  assumes "i  fvset (set K). i < length T"
  shows "(K list (!) T) list δ = K list ((!) (map (λt. t  δ) T))" (is "?A = ?B")
proof -
  have "T ! i  δ = (map (λt. t  δ) T) ! i"
    when "i < length T" for i
    using that by auto
  hence "T ! i  δ = (map (λt. t  δ) T) ! i"
    when "i  fvset (set K)" for i
    using that assms by auto
  hence "k  (!) T  δ = k  (!) (map (λt. t  δ) T)"
    when "fv k  fvset (set K)" for k
    using that by (induction k) force+
  thus ?thesis by auto
qed

lemma subst_remove_var: "v  fv s  v  fv (t  Var(v := s))"
by (induct t) simp_all

lemma subst_set_map: "x  set X  x  s  set (map (λx. x  s) X)"
by simp

lemma subst_set_idx_map:
  assumes "i  I. i < length T"
  shows "(!) T ` I set δ = (!) (map (λt. t  δ) T) ` I" (is "?A = ?B")
proof
  have *: "T ! i  δ = (map (λt. t  δ) T) ! i"
    when "i < length T" for i
    using that by auto
  
  show "?A  ?B" using * assms by blast
  show "?B  ?A" using * assms by auto
qed

lemma subst_set_idx_map':
  assumes "i  fvset K. i < length T"
  shows "K set (!) T set δ = K set (!) (map (λt. t  δ) T)" (is "?A = ?B")
proof
  have "T ! i  δ = (map (λt. t  δ) T) ! i"
    when "i < length T" for i
    using that by auto
  hence "T ! i  δ = (map (λt. t  δ) T) ! i"
    when "i  fvset K" for i
    using that assms by auto
  hence *: "k  (!) T  δ = k  (!) (map (λt. t  δ) T)"
    when "fv k  fvset K" for k
    using that by (induction k) force+

  show "?A  ?B" using * by auto
  show "?B  ?A" using * by force
qed

lemma subst_term_list_obtain:
  assumes "i < length T. s. P (T ! i) s  S ! i = s  δ"
    and "length T = length S"
  shows "U. length T = length U  (i < length T. P (T ! i) (U ! i))  S = map (λu. u  δ) U"
using assms
proof (induction T arbitrary: S)
  case (Cons t T S')
  then obtain s S where S': "S' = s#S" by (cases S') auto

  have "i < length T. s. P (T ! i) s  S ! i = s  δ" "length T = length S"
    using Cons.prems S' by force+
  then obtain U where U:
      "length T = length U" "i < length T. P (T ! i) (U ! i)" "S = map (λu. u  δ) U"
    using Cons.IH by moura

  obtain u where u: "P t u" "s = u  δ"
    using Cons.prems(1) S' by auto

  have 1: "length (t#T) = length (u#U)"
    using Cons.prems(2) U(1) by fastforce

  have 2: "i < length (t#T). P ((t#T) ! i) ((u#U) ! i)"
    using u(1) U(2) by (simp add: nth_Cons')

  have 3: "S' = map (λu. u  δ) (u#U)"
    using U u S' by simp

  show ?case using 1 2 3 by blast
qed simp

lemma subst_mono: "t  u  t  s  u  s"
by (induct u) auto

lemma subst_mono_fv: "x  fv t  s x  t  s"
by (induct t) auto

lemma subst_mono_neq:
  assumes "t  u"
  shows "t  s  u  s"
proof (cases u)
  case (Var v)
  hence False using t  u by simp
  thus ?thesis ..
next
  case (Fun f X)
  then obtain x where "x  set X" "t  x" using t  u by auto
  hence "t  s  x  s" using subst_mono by metis

  obtain Y where "Fun f X  s = Fun f Y" by auto
  hence "x  s  set Y" using x  set X by auto
  hence "x  s  Fun f X  s" using ‹Fun f X  s = Fun f Y Fun_param_is_subterm by simp
  hence "t  s  Fun f X  s" using t  s  x  s by (metis term.dual_order.trans term.eq_iff)
  thus ?thesis using u = Fun f X t  u by metis
qed

lemma subst_no_occs[dest]: "¬Var v  t  t  Var(v := s) = t"
by (induct t) (simp_all add: map_idI)

lemma var_comp[simp]: "σ s Var = σ" "Var s σ = σ"
unfolding subst_compose_def by simp_all

lemma subst_comp_all: "M set (δ s θ) = (M set δ) set θ"
using subst_subst_compose[of _ δ θ] by auto

lemma subst_all_mono: "M  M'  M set s  M' set s"
by auto

lemma subst_comp_set_image: "(δ s θ) ` X = δ ` X set θ"
using subst_compose by fastforce

lemma subst_ground_ident[dest?]: "fv t = {}  t  s = t"
by (induct t, simp, metis subst_agreement empty_iff subst_apply_term_empty)

lemma subst_ground_ident_compose:
  "fv (σ x) = {}  (σ s θ) x = σ x"
  "fv (t  σ) = {}  t  (σ s θ) = t  σ"
using subst_subst_compose[of t σ θ]
by (simp_all add: subst_compose_def subst_ground_ident)

lemma subst_all_ground_ident[dest?]: "ground M  M set s = M"
proof -
  assume "ground M"
  hence "t. t  M  fv t = {}" by auto
  hence "t. t  M  t  s = t" by (metis subst_ground_ident)
  moreover have "t. t  M  t  s  M set s" by (metis imageI)
  ultimately show "M set s = M" by (simp add: image_cong)
qed

lemma subst_eqI[intro]: "(t. t  σ = t  θ)  σ = θ"
proof -
  assume "t. t  σ = t  θ"
  hence "v. Var v  σ = Var v  θ" by auto
  thus "σ = θ" by auto
qed

lemma subst_cong: "σ = σ'; θ = θ'  (σ s θ) = (σ' s θ')"
by auto

lemma subst_mgt_bot[simp]: "Var  θ"
by simp

lemma subst_mgt_refl[simp]: "θ  θ"
by (metis var_comp(1))

lemma subst_mgt_trans: "θ  δ; δ  σ  θ  σ"
by (metis subst_compose_assoc)

lemma subst_mgt_comp: "θ  θ s δ"
by auto

lemma subst_mgt_comp': "θ s δ  σ  θ  σ"
by (metis subst_compose_assoc)

lemma var_self: "(λw. if w = v then Var v else Var w) = Var"
using subst_agreement by auto

lemma var_same[simp]: "Var(v := t) = Var  t = Var v"
by (intro iffI, metis fun_upd_same, simp add: var_self)

lemma subst_eq_if_eq_vars: "(v. (Var v)  θ = (Var v)  σ)  θ = σ"
by (auto simp add: subst_agreement)

lemma subst_all_empty[simp]: "{} set θ = {}"
by simp

lemma subst_all_insert:"(insert t M) set δ = insert (t  δ) (M set δ)"
by auto

lemma subst_apply_fv_subset: "fv t  V  fv (t  δ)  fvset (δ ` V)"
by (induct t) auto

lemma subst_apply_fv_empty:
  assumes "fv t = {}"
  shows "fv (t  σ) = {}"
using assms subst_apply_fv_subset[of t "{}" σ]
by auto

lemma subst_compose_fv:
  assumes "fv (θ x) = {}"
  shows "fv ((θ s σ) x) = {}"
using assms subst_apply_fv_empty
unfolding subst_compose_def by fast

lemma subst_compose_fv':
  fixes θ σ::"('a,'b) subst"
  assumes "y  fv ((θ s σ) x)"
  shows "z. z  fv (θ x)"
using assms subst_compose_fv
by fast

lemma subst_apply_fv_unfold: "fv (t  δ) = fvset (δ ` fv t)"
by (induct t) auto

lemma subst_apply_fv_unfold': "fv (t  δ) = (v  fv t. fv (δ v))"
using subst_apply_fv_unfold by simp

lemma subst_apply_fv_union: "fvset (δ ` V)  fv (t  δ) = fvset (δ ` (V  fv t))"
proof -
  have "fvset (δ ` (V  fv t)) = fvset (δ ` V)  fvset (δ ` fv t)" by auto
  thus ?thesis using subst_apply_fv_unfold by metis
qed

lemma subst_elimI[intro]: "(t. v  fv (t  σ))  subst_elim σ v"
by (auto simp add: subst_elim_def)

lemma subst_elimI'[intro]: "(w. v  fv (Var w  θ))  subst_elim θ v"
by (simp add: subst_elim_def subst_apply_fv_unfold') 

lemma subst_elimD[dest]: "subst_elim σ v  v  fv (t  σ)"
by (auto simp add: subst_elim_def)

lemma subst_elimD'[dest]: "subst_elim σ v  σ v  Var v"
by (metis subst_elim_def subst_apply_term.simps(1) term.set_intros(3))

lemma subst_elimD''[dest]: "subst_elim σ v  v  fv (σ w)"
by (metis subst_elim_def subst_apply_term.simps(1))

lemma subst_elim_rm_vars_dest[dest]:
  "subst_elim (σ::('a,'b) subst) v  v  vs  subst_elim (rm_vars vs σ) v"
proof -
  assume assms: "subst_elim σ v" "v  vs"
  obtain f::"('a, 'b) subst  'b  'b" where
      "σ v. (w. v  fv (Var w  σ)) = (v  fv (Var (f σ v)  σ))"
    by moura
  hence *: "a σ. a  fv (Var (f σ a)  σ)  subst_elim σ a" by blast
  have "Var (f (rm_vars vs σ) v)  σ  Var (f (rm_vars vs σ) v)  rm_vars vs σ
         v  fv (Var (f (rm_vars vs σ) v)  rm_vars vs σ)"
    using assms(1) by fastforce
  moreover
  { assume "Var (f (rm_vars vs σ) v)  σ  Var (f (rm_vars vs σ) v)  rm_vars vs σ"
    hence "rm_vars vs σ (f (rm_vars vs σ) v)  σ (f (rm_vars vs σ) v)" by auto
    hence "f (rm_vars vs σ) v  vs" by meson
    hence ?thesis using * assms(2) by force
  }
  ultimately show ?thesis using * by blast
qed

lemma occs_subst_elim: "¬Var v  t  subst_elim (Var(v := t)) v  (Var(v := t)) = Var"
proof (cases "Var v = t")
  assume "Var v  t" "¬Var v  t"
  hence "v  fv t" by (simp add: vars_iff_subterm_or_eq)
  thus ?thesis by (auto simp add: subst_remove_var)
qed auto

lemma occs_subst_elim': "¬Var v  t  subst_elim (Var(v := t)) v"
proof -
  assume "¬Var v  t"
  hence "v  fv t" by (auto simp add: vars_iff_subterm_or_eq)
  thus "subst_elim (Var(v := t)) v" by (simp add: subst_elim_def subst_remove_var)
qed

lemma subst_elim_comp: "subst_elim θ v  subst_elim (δ s θ) v"
by (auto simp add: subst_elim_def)

lemma var_subst_idem: "subst_idem Var"
by (simp add: subst_idem_def)

lemma var_upd_subst_idem:
  assumes "¬Var v  t" shows "subst_idem (Var(v := t))"
unfolding subst_idem_def
proof
  let  = "Var(v := t)"
  from assms have t_θ_id: "t   = t" by blast
  fix s show "s  ( s ) = s  "
    unfolding subst_compose_def
    by (induction s, metis t_θ_id fun_upd_def subst_apply_term.simps(1), simp) 
qed


subsection ‹Lemmata: Domain and Range of Substitutions›
lemma range_vars_alt_def: "range_vars s  fvset (subst_range s)"
unfolding range_vars_def by simp

lemma subst_dom_var_finite[simp]: "finite (subst_domain Var)" by simp

lemma subst_range_Var[simp]: "subst_range Var = {}" by simp

lemma range_vars_Var[simp]: "range_vars Var = {}" by fastforce

lemma finite_subst_img_if_finite_dom: "finite (subst_domain σ)  finite (range_vars σ)"
unfolding range_vars_alt_def by auto

lemma finite_subst_img_if_finite_dom': "finite (subst_domain σ)  finite (subst_range σ)"
by auto

lemma subst_img_alt_def: "subst_range s = {t. v. s v = t  t  Var v}"
by (auto simp add: subst_domain_def)

lemma subst_fv_img_alt_def: "range_vars s = (t  {t. v. s v = t  t  Var v}. fv t)"
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)

lemma subst_domI[intro]: "σ v  Var v  v  subst_domain σ"
by (simp add: subst_domain_def)

lemma subst_imgI[intro]: "σ v  Var v  σ v  subst_range σ"
by (simp add: subst_domain_def)

lemma subst_fv_imgI[intro]: "σ v  Var v  fv (σ v)  range_vars σ"
unfolding range_vars_alt_def by auto

lemma subst_domain_subst_Fun_single[simp]:
  "subst_domain (Var(x := Fun f T)) = {x}" (is "?A = ?B")
unfolding subst_domain_def by simp

lemma subst_range_subst_Fun_single[simp]:
  "subst_range (Var(x := Fun f T)) = {Fun f T}" (is "?A = ?B")
by simp

lemma range_vars_subst_Fun_single[simp]:
  "range_vars (Var(x := Fun f T)) = fv (Fun f T)"
unfolding range_vars_alt_def by force

lemma var_renaming_is_Fun_iff:
  assumes "subst_range δ  range Var"
  shows "is_Fun t = is_Fun (t  δ)"
proof (cases t)
  case (Var x)
  hence "y. δ x = Var y" using assms by auto
  thus ?thesis using Var by auto
qed simp

lemma subst_fv_dom_img_subset: "fv t  subst_domain θ  fv (t  θ)  range_vars θ"
unfolding range_vars_alt_def by (induct t) auto

lemma subst_fv_dom_img_subset_set: "fvset M  subst_domain θ  fvset (M set θ)  range_vars θ"
proof -
  assume assms: "fvset M  subst_domain θ"
  obtain f::"'a set  (('b, 'a) term  'a set)  ('b, 'a) terms  ('b, 'a) term" where
      "x y z. (v. v  z  ¬ y v  x)  (f x y z  z  ¬ y (f x y z)  x)"
    by moura
  hence *:
      "T g A. (¬  (g ` T)  A  (t. t  T  g t  A)) 
               ( (g ` T)  A  f A g T  T  ¬ g (f A g T)  A)"
    by (metis (no_types) SUP_le_iff)
  hence **: "t. t  M  fv t  subst_domain θ" by (metis (no_types) assms fvset.simps)
  have "t::('b, 'a) term. f T. t  f ` T  (t'::('b, 'a) term. t = f t'  t'  T)" by blast
  hence "f (range_vars θ) fv (M set θ)  M set θ 
         fv (f (range_vars θ) fv (M set θ))  range_vars θ"
    by (metis (full_types) ** subst_fv_dom_img_subset)
  thus ?thesis by (metis (no_types) * fvset.simps)
qed

lemma subst_fv_dom_ground_if_ground_img:
  assumes "fv t  subst_domain s" "ground (subst_range s)"
  shows "fv (t  s) = {}"
using subst_fv_dom_img_subset[OF assms(1)] assms(2) by force

lemma subst_fv_dom_ground_if_ground_img':
  assumes "fv t  subst_domain s" "x. x  subst_domain s  fv (s x) = {}"
  shows "fv (t  s) = {}"
using subst_fv_dom_ground_if_ground_img[OF assms(1)] assms(2) by auto

lemma subst_fv_unfold: "fv (t  s) = (fv t - subst_domain s)  fvset (s ` (fv t  subst_domain s))"
proof (induction t)
  case (Var v) thus ?case
  proof (cases "v  subst_domain s")
    case True thus ?thesis by auto
  next
    case False
    hence "fv (Var v  s) = {v}" "fv (Var v)  subst_domain s = {}" by auto
    thus ?thesis by auto
  qed
next
  case Fun thus ?case by auto
qed

lemma subst_fv_unfold_ground_img: "range_vars s = {}  fv (t  s) = fv t - subst_domain s"
using subst_fv_unfold[of t s] unfolding range_vars_alt_def by auto

lemma subst_img_update:
  "σ v = Var v; t  Var v  range_vars (σ(v := t)) = range_vars σ  fv t"
proof -
  assume "σ v = Var v" "t  Var v"
  hence "(s  {s. w. (σ(v := t)) w = s  s  Var w}. fv s) = fv t  range_vars σ"
    unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
  thus "range_vars (σ(v := t)) = range_vars σ  fv t"
    by (metis Un_commute subst_fv_img_alt_def)
qed

lemma subst_dom_update1: "v  subst_domain σ  subst_domain (σ(v := Var v)) = subst_domain σ"
by (auto simp add: subst_domain_def)

lemma subst_dom_update2: "t  Var v  subst_domain (σ(v := t)) = insert v (subst_domain σ)"
by (auto simp add: subst_domain_def)

lemma subst_dom_update3: "t = Var v  subst_domain (σ(v := t)) = subst_domain σ - {v}"
by (auto simp add: subst_domain_def)

lemma var_not_in_subst_dom[elim]: "v  subst_domain s  s v = Var v"
by (simp add: subst_domain_def)

lemma subst_dom_vars_in_subst[elim]: "v  subst_domain s  s v  Var v"
by (simp add: subst_domain_def)

lemma subst_not_dom_fixed: "v  fv t; v  subst_domain s  v  fv (t  s)" by (induct t) auto

lemma subst_not_img_fixed: "v  fv (t  s); v  range_vars s  v  fv t"
unfolding range_vars_alt_def by (induct t) force+

lemma ground_range_vars[intro]: "ground (subst_range s)  range_vars s = {}"
unfolding range_vars_alt_def by metis

lemma ground_subst_no_var[intro]: "ground (subst_range s)  x  range_vars s"
using ground_range_vars[of s] by blast

lemma ground_img_obtain_fun:
  assumes "ground (subst_range s)" "x  subst_domain s"
  obtains f T where "s x = Fun f T" "Fun f T  subst_range s" "fv (Fun f T) = {}"
proof -
  from assms(2) obtain t where t: "s x = t" "t  subst_range s" by moura
  hence "fv t = {}" using assms(1) by auto
  thus ?thesis using t that by (cases t) simp_all
qed

lemma ground_term_subst_domain_fv_subset:
  "fv (t  δ) = {}  fv t  subst_domain δ"
by (induct t) auto

lemma ground_subst_range_empty_fv:
  "ground (subst_range θ)  x  subst_domain θ  fv (θ x) = {}"
by simp

lemma subst_Var_notin_img: "x  range_vars s  t  s = Var x  t = Var x"
using subst_not_img_fixed[of x t s] by (induct t) auto

lemma fv_in_subst_img: "s v = t; t  Var v  fv t  range_vars s"
unfolding range_vars_alt_def by auto

lemma empty_dom_iff_empty_subst: "subst_domain θ = {}  θ = Var" by auto

lemma subst_dom_cong: "(v t. θ v = t  δ v = t)  subst_domain θ  subst_domain δ"
by (auto simp add: subst_domain_def)

lemma subst_img_cong: "(v t. θ v = t  δ v = t)  range_vars θ  range_vars δ"
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)

lemma subst_dom_elim: "subst_domain s  range_vars s = {}  fv (t  s)  subst_domain s = {}"
proof (induction t)
  case (Var v) thus ?case
    using fv_in_subst_img[of s] 
    by (cases "s v = Var v") (auto simp add: subst_domain_def)
next
  case Fun thus ?case by auto
qed

lemma subst_dom_insert_finite: "finite (subst_domain s) = finite (subst_domain (s(v := t)))"
proof
  assume "finite (subst_domain s)"
  have "subst_domain (s(v := t))  insert v (subst_domain s)" by (auto simp add: subst_domain_def)
  thus "finite (subst_domain (s(v := t)))"
    by (meson ‹finite (subst_domain s) finite_insert rev_finite_subset)
next
  assume *: "finite (subst_domain (s(v := t)))"
  hence "finite (insert v (subst_domain s))"
  proof (cases "t = Var v")
    case True
    hence "finite (subst_domain s - {v})" by (metis * subst_dom_update3)
    thus ?thesis by simp
  qed (metis * subst_dom_update2[of t v s])
  thus "finite (subst_domain s)" by simp
qed

lemma trm_subst_disj: "t  θ = t  fv t  subst_domain θ = {}"
proof (induction t)
  case (Fun f X)
  hence "map (λx. x  θ) X = X" by simp
  hence "x. x  set X  x  θ = x" using map_eq_conv by fastforce
  thus ?case using Fun.IH by auto
qed (simp add: subst_domain_def)

lemma trm_subst_ident[intro]: "fv t  subst_domain θ = {}  t  θ = t"
proof -
  assume "fv t  subst_domain θ = {}"
  hence "v  fv t. w  subst_domain θ. v  w" by auto
  thus ?thesis
    by (metis subst_agreement subst_apply_term.simps(1) subst_apply_term_empty subst_domI)
qed

lemma trm_subst_ident'[intro]: "v  subst_domain θ  (Var v)  θ = Var v"
using trm_subst_ident by (simp add: subst_domain_def)

lemma trm_subst_ident''[intro]: "(x. x  fv t  θ x = Var x)  t  θ = t"
proof -
  assume "x. x  fv t  θ x = Var x"
  hence "fv t  subst_domain θ = {}" by (auto simp add: subst_domain_def)
  thus ?thesis using trm_subst_ident by auto
qed

lemma set_subst_ident: "fvset M  subst_domain θ = {}  M set θ = M"
proof -
  assume "fvset M  subst_domain θ = {}"
  hence "t  M. t  θ = t" by auto
  thus ?thesis by force
qed

lemma trm_subst_ident_subterms[intro]:
  "fv t  subst_domain θ = {}  subterms t set θ = subterms t"
using set_subst_ident[of "subterms t" θ] fv_subterms[of t] by simp

lemma trm_subst_ident_subterms'[intro]:
  "v  fv t  subterms t set Var(v := s) = subterms t"
using trm_subst_ident_subterms[of t "Var(v := s)"]
by (meson subst_no_occs trm_subst_disj vars_iff_subtermeq) 

lemma const_mem_subst_cases:
  assumes "Fun c []  M set θ"
  shows "Fun c []  M  Fun c []  θ ` fvset M"
proof -
  obtain m where m: "m  M" "m  θ = Fun c []" using assms by auto
  thus ?thesis by (cases m) force+
qed

lemma const_mem_subst_cases':
  assumes "Fun c []  M set θ"
  shows "Fun c []  M  Fun c []  subst_range θ"
using const_mem_subst_cases[OF assms] by force

lemma fv_subterms_substI[intro]: "y  fv t  θ y  subterms t set θ"
using image_iff vars_iff_subtermeq by fastforce 

lemma fv_subterms_subst_eq[simp]: "fvset (subterms (t  θ)) = fvset (subterms t set θ)"
using fv_subterms by (induct t) force+

lemma fv_subterms_set_subst: "fvset (subtermsset M set θ) = fvset (subtermsset (M set θ))"
using fv_subterms_subst_eq[of _ θ] by auto

lemma fv_subterms_set_subst': "fvset (subtermsset M set θ) = fvset (M set θ)"
using fv_subterms_set[of "M set θ"] fv_subterms_set_subst[of θ M] by simp

lemma fv_subst_subset: "x  fv t  fv (θ x)  fv (t  θ)"
by (metis fv_subset image_eqI subst_apply_fv_unfold)

lemma fv_subst_subset': "fv s  fv t  fv (s  θ)  fv (t  θ)"
using fv_subst_subset by (induct s) force+

lemma fv_subst_obtain_var:
  fixes δ::"('a,'b) subst"
  assumes "x  fv (t  δ)"
  shows "y  fv t. x  fv (δ y)"
using assms by (induct t) force+

lemma set_subst_all_ident: "fvset (M set θ)  subst_domain δ = {}  M set (θ s δ) = M set θ"
by (metis set_subst_ident subst_comp_all)

lemma subterms_subst:
  "subterms (t  d) = (subterms t set d)  subtermsset (d ` (fv t  subst_domain d))"
by (induct t) (auto simp add: subst_domain_def)

lemma subterms_subst':
  fixes θ::"('a,'b) subst"
  assumes "x  fv t. (f. θ x = Fun f [])  (y. θ x = Var y)"
  shows "subterms (t  θ) = subterms t set θ"
using assms
proof (induction t)
  case (Var x) thus ?case
  proof (cases "x  subst_domain θ")
    case True
    hence "(f. θ x = Fun f [])  (y. θ x = Var y)" using Var by simp
    hence "subterms (θ x) = {θ x}" by auto
    thus ?thesis by simp
  qed auto
qed auto

lemma subterms_subst'':
  fixes θ::"('a,'b) subst"
  assumes "x  fvset M. (f. θ x = Fun f [])  (y. θ x = Var y)"
  shows "subtermsset (M set θ) = subtermsset M set θ"
using subterms_subst'[of _ θ] assms by auto

lemma subterms_subst_subterm:
  fixes θ::"('a,'b) subst"
  assumes "x  fv a. (f. θ x = Fun f [])  (y. θ x = Var y)"
    and "b  subterms (a  θ)"
  shows "c  subterms a. c  θ = b"
using subterms_subst'[OF assms(1)] assms(2) by auto

lemma subterms_subst_subset: "subterms t set σ  subterms (t  σ)"
by (induct t) auto

lemma subterms_subst_subset': "subtermsset M set σ  subtermsset (M set σ)"
using subterms_subst_subset by fast

lemma subtermsset_subst:
  fixes θ::"('a,'b) subst"
  assumes "t  subtermsset (M set θ)"
  shows "t  subtermsset M set θ  (x  fvset M. t  subterms (θ x))"
using assms subterms_subst[of _ θ] by auto

lemma rm_vars_dom: "subst_domain (rm_vars V s) = subst_domain s - V"
by (auto simp add: subst_domain_def)

lemma rm_vars_dom_subset: "subst_domain (rm_vars V s)  subst_domain s"
by (auto simp add: subst_domain_def)

lemma rm_vars_dom_eq':
  "subst_domain (rm_vars (UNIV - V) s) = subst_domain s  V"
using rm_vars_dom[of "UNIV - V" s] by blast

lemma rm_vars_img: "subst_range (rm_vars V s) = s ` subst_domain (rm_vars V s)"
by (auto simp add: subst_domain_def)

lemma rm_vars_img_subset: "subst_range (rm_vars V s)  subst_range s"
by (auto simp add: subst_domain_def)

lemma rm_vars_img_fv_subset: "range_vars (rm_vars V s)  range_vars s"
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)

lemma rm_vars_fv_obtain:
  assumes "x  fv (t  rm_vars X θ) - X"
  shows "y  fv t - X. x  fv (rm_vars X θ y)"
using assms by (induct t) (fastforce, force)

lemma rm_vars_apply: "v  subst_domain (rm_vars V s)  (rm_vars V s) v = s v"
by (auto simp add: subst_domain_def)

lemma rm_vars_apply': "subst_domain δ  vs = {}  rm_vars vs δ = δ"
by force

lemma rm_vars_ident: "fv t  vs = {}  t  (rm_vars vs θ) = t  θ"
by (induct t) auto

lemma rm_vars_fv_subset: "fv (t  rm_vars X θ)  fv t  fv (t  θ)"
by (induct t) auto

lemma rm_vars_fv_disj:
  assumes "fv t  X = {}" "fv (t  θ)  X = {}"
  shows "fv (t  rm_vars X θ)  X = {}"
using rm_vars_ident[OF assms(1)] assms(2) by auto

lemma rm_vars_ground_supports:
  assumes "ground (subst_range θ)"
  shows "rm_vars X θ supports θ"
proof
  fix x
  have *: "ground (subst_range (rm_vars X θ))"
    using rm_vars_img_subset[of X θ] assms
    by (auto simp add: subst_domain_def)
  show "rm_vars X θ x  θ = θ x "
  proof (cases "x  subst_domain (rm_vars X θ)")
    case True
    hence "fv (rm_vars X θ x) = {}" using * by auto
    thus ?thesis using True by auto
  qed (simp add: subst_domain_def)
qed

lemma rm_vars_split:
  assumes "ground (subst_range θ)"
  shows "θ = rm_vars X θ s rm_vars (subst_domain θ - X) θ"
proof -
  let ?s1 = "rm_vars X θ"
  let ?s2 = "rm_vars (subst_domain θ - X) θ"

  have doms: "subst_domain ?s1  subst_domain θ" "subst_domain ?s2  subst_domain θ"
    by (auto simp add: subst_domain_def)

  { fix x assume "x  subst_domain θ"
    hence "θ x = Var x" "?s1 x = Var x" "?s2 x = Var x" using doms by auto
    hence "θ x = (?s1 s ?s2) x" by (simp add: subst_compose_def)
  } moreover {
    fix x assume "x  subst_domain θ" "x  X"
    hence "?s1 x = Var x" "?s2 x = θ x" using doms by auto
    hence "θ x = (?s1 s ?s2) x" by (simp add: subst_compose_def)
  } moreover {
    fix x assume "x  subst_domain θ" "x  X"
    hence "?s1 x = θ x" "fv (θ x) = {}" using assms doms by auto
    hence "θ x = (?s1 s ?s2) x" by (simp add: subst_compose subst_ground_ident)
  } ultimately show ?thesis by blast
qed

lemma rm_vars_fv_img_disj:
  assumes "fv t  X = {}" "X  range_vars θ = {}"
  shows "fv (t  rm_vars X θ)  X = {}"
using assms
proof (induction t)
  case (Var x)
  hence *: "(rm_vars X θ) x = θ x" by auto
  show ?case
  proof (cases "x  subst_domain θ")
    case True
    hence "θ x  subst_range θ" by auto
    hence "fv (θ x)  X = {}" using Var.prems(2) unfolding range_vars_alt_def by fastforce
    thus ?thesis using * by auto
  next
    case False thus ?thesis using Var.prems(1) by auto
  qed
next
  case Fun thus ?case by auto
qed

lemma subst_apply_dom_ident: "t  θ = t  subst_domain δ  subst_domain θ  t  δ = t"
proof (induction t)
  case (Fun f T) thus ?case by (induct T) auto
qed (auto simp add: subst_domain_def)

lemma rm_vars_subst_apply_ident:
  assumes "t  θ = t"
  shows "t  (rm_vars vs θ) = t"
using rm_vars_dom[of vs θ] subst_apply_dom_ident[OF assms, of "rm_vars vs θ"] by auto

lemma rm_vars_subst_eq:
  "t  δ = t  rm_vars (subst_domain δ - subst_domain δ  fv t) δ"
by (auto intro: term_subst_eq)

lemma rm_vars_subst_eq':
  "t  δ = t  rm_vars (UNIV - fv t) δ"
by (auto intro: term_subst_eq)

lemma rm_vars_comp:
  assumes "range_vars δ  vs = {}"
  shows "t  rm_vars vs (δ s θ) = t  (rm_vars vs δ s rm_vars vs θ)"
using assms
proof (induction t)
  case (Var x) thus ?case
  proof (cases "x  vs")
    case True thus ?thesis using Var by auto
  next
    case False
    have "subst_domain (rm_vars vs θ)  vs = {}" by (auto simp add: subst_domain_def)
    moreover have "fv (δ x)  vs = {}"
      using Var False unfolding range_vars_alt_def by force
    ultimately have "δ x  (rm_vars vs θ) = δ x  θ"
      using rm_vars_ident by (simp add: subst_domain_def)
    moreover have "(rm_vars vs (δ s θ)) x = (δ s θ) x" by (metis False)
    ultimately show ?thesis using subst_compose by auto
  qed
next
  case Fun thus ?case by auto
qed

lemma rm_vars_fvset_subst:
  assumes "x  fvset (rm_vars X θ ` Y)"
  shows "x  fvset (θ ` Y)  x  X"
using assms by auto

lemma disj_dom_img_var_notin:
  assumes "subst_domain θ  range_vars θ = {}" "θ v = t" "t  Var v"
  shows "v  fv t" "v  fv (t  θ). v  subst_domain θ"
proof -
  have "v  subst_domain θ" "fv t  range_vars θ"
    using fv_in_subst_img[of θ v t, OF assms(2)] assms(2,3)
    by (auto simp add: subst_domain_def)
  thus "v  fv t" using assms(1) by auto

  have *: "fv t  subst_domain θ = {}"
    using assms(1) ‹fv t  range_vars θ
    by auto
  hence "t  θ = t" by blast
  thus "v  fv (t  θ). v  subst_domain θ" using * by auto
qed

lemma subst_sends_dom_to_img: "v  subst_domain θ  fv (Var v  θ)  range_vars θ"
unfolding range_vars_alt_def by auto

lemma subst_sends_fv_to_img: "fv (t  s)  fv t  range_vars s"
proof (induction t)
  case (Var v) thus ?case
  proof (cases "Var v  s = Var v")
    case True thus ?thesis by simp
  next
    case False
    hence "v  subst_domain s" by (meson trm_subst_ident') 
    hence "fv (Var v  s)  range_vars s"
      using subst_sends_dom_to_img by simp
    thus ?thesis by auto
  qed
next
  case Fun thus ?case by auto
qed 

lemma ident_comp_subst_trm_if_disj:
  assumes "subst_domain σ  range_vars θ = {}" "v  subst_domain θ"
  shows "(θ s σ) v = θ v"
proof -
  from assms have " subst_domain σ  fv (θ v) = {}"
    using fv_in_subst_img unfolding range_vars_alt_def by auto
  thus "(θ s σ) v = θ v" unfolding subst_compose_def by blast
qed

lemma ident_comp_subst_trm_if_disj': "fv (θ v)  subst_domain σ = {}  (θ s σ) v = θ v"
unfolding subst_compose_def by blast

lemma subst_idemI[intro]: "subst_domain σ  range_vars σ = {}  subst_idem σ"
using ident_comp_subst_trm_if_disj[of σ σ]
      var_not_in_subst_dom[of _ σ]
      subst_eq_if_eq_vars[of σ]
by (metis subst_idem_def subst_compose_def var_comp(2)) 

lemma subst_idemI'[intro]: "ground (subst_range σ)  subst_idem σ"
proof (intro subst_idemI)
  assume "ground (subst_range σ)"
  hence "range_vars σ = {}" by (metis ground_range_vars)
  thus "subst_domain σ  range_vars σ = {}" by blast
qed

lemma subst_idemE: "subst_idem σ  subst_domain σ  range_vars σ = {}"
proof -
  assume "subst_idem σ"
  hence "v. fv (σ v)  subst_domain σ = {}"
    unfolding subst_idem_def subst_compose_def by (metis trm_subst_disj)
  thus ?thesis
    unfolding range_vars_alt_def by auto
qed

lemma subst_idem_rm_vars: "subst_idem θ  subst_idem (rm_vars X θ)"
proof -
  assume "subst_idem θ"
  hence "subst_domain θ  range_vars θ = {}" by (metis subst_idemE)
  moreover have
      "subst_domain (rm_vars X θ)  subst_domain θ"
      "range_vars (rm_vars X θ)  range_vars θ"
    unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
  ultimately show ?thesis by blast
qed

lemma subst_fv_bounded_if_img_bounded: "range_vars θ  fv t  V  fv (t  θ)  fv t  V"
proof (induction t)
  case (Var v) thus ?case unfolding range_vars_alt_def by (cases "θ v = Var v") auto
qed (metis (no_types, lifting) Un_assoc Un_commute subst_sends_fv_to_img sup.absorb_iff2)

lemma subst_fv_bound_singleton: "fv (t  Var(v := t'))  fv t  fv t'"
using subst_fv_bounded_if_img_bounded[of "Var(v := t')" t "fv t'"]
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)

lemma subst_fv_bounded_if_img_bounded':
  assumes "range_vars θ  fvset M"
  shows "fvset (M set θ)  fvset M"
proof
  fix v assume *:  "v  fvset (M set θ)"
  
  obtain t where t: "t  M" "t  θ  M set θ" "v  fv (t  θ)"
  proof -
    assume **: "t. t  M; t  θ  M set θ; v  fv (t  θ)  thesis"
    have "v   (fv ` ((λt. t  θ) ` M))" using * by (metis fvset.simps)
    hence "t. t  M  v  fv (t  θ)" by blast
    thus ?thesis using ** imageI by blast
  qed

  from t  M obtain M' where "t  M'" "M = insert t M'" by (meson Set.set_insert) 
  hence "fvset M = fv t  fvset M'" by simp
  hence "fv (t  θ)  fvset M" using subst_fv_bounded_if_img_bounded assms by simp
  thus "v  fvset M" using assms v  fv (t  θ) by auto
qed

lemma ground_img_if_ground_subst: "(v t. s v = t  fv t = {})  range_vars s = {}"
unfolding range_vars_alt_def by auto

lemma ground_subst_fv_subset: "ground (subst_range θ)  fv (t  θ)  fv t"
using subst_fv_bounded_if_img_bounded[of θ]
unfolding range_vars_alt_def by force

lemma ground_subst_fv_subset': "ground (subst_range θ)  fvset (M set θ)  fvset M"
using subst_fv_bounded_if_img_bounded'[of θ M]
unfolding range_vars_alt_def by auto

lemma subst_to_var_is_var[elim]: "t  s = Var v  w. t = Var w"
using subst_apply_term.elims by blast

lemma subst_dom_comp_inI:
  assumes "y  subst_domain σ"
    and "y  subst_domain δ"
  shows "y  subst_domain (σ s δ)"
using assms subst_domain_subst_compose[of σ δ] by blast

lemma subst_comp_notin_dom_eq:
  "x  subst_domain θ1  (θ1 s θ2) x = θ2 x"
unfolding subst_compose_def by fastforce

lemma subst_dom_comp_eq:
  assumes "subst_domain θ  range_vars σ = {}"
  shows "subst_domain (θ s σ) = subst_domain θ  subst_domain σ"
proof (rule ccontr)
  assume "subst_domain (θ s σ)  subst_domain θ  subst_domain σ"
  hence "subst_domain (θ s σ)  subst_domain θ  subst_domain σ"
    using subst_domain_compose[of θ σ] by (simp add: subst_domain_def)
  then obtain v where "v  subst_domain (θ s σ)" "v  subst_domain θ  subst_domain σ" by auto
  hence v_in_some_subst: "θ v  Var v  σ v  Var v" and "θ v  σ = Var v"
    unfolding subst_compose_def by (auto simp add: subst_domain_def)
  then obtain w where "θ v = Var w" using subst_to_var_is_var by fastforce
  show False
  proof (cases "v = w")
    case True
    hence "θ v = Var v" using θ v = Var w by simp
    hence "σ v  Var v" using v_in_some_subst by simp
    thus False using θ v = Var v θ v  σ = Var v by simp
  next
    case False
    hence "v  subst_domain θ" using v_in_some_subst θ v  σ = Var v by auto 
    hence "v  range_vars σ" using assms by auto
    moreover have "σ w = Var v" using θ v  σ = Var v θ v = Var w by simp
    hence "v  range_vars σ" using v  w subst_fv_imgI[of σ w] by simp
    ultimately show False ..
  qed
qed

lemma subst_img_comp_subset[simp]:
  "range_vars (θ1 s θ2)  range_vars θ1  range_vars θ2"
proof
  let ?img = "range_vars"
  fix x assume "x  ?img (θ1 s θ2)"
  then obtain v t where vt: "x  fv t" "t = (θ1 s θ2) v" "t  Var v"
    unfolding range_vars_alt_def subst_compose_def by (auto simp add: subst_domain_def)

  { assume "x  ?img θ1" hence "x  ?img θ2"
      by (metis (no_types, hide_lams) fv_in_subst_img Un_iff subst_compose_def 
                vt subsetCE subst_apply_term.simps(1) subst_sends_fv_to_img) 
  }
  thus "x  ?img θ1  ?img θ2" by auto
qed

lemma subst_img_comp_subset':
  assumes "t  subst_range (θ1 s θ2)"
  shows "t  subst_range θ2  (t'  subst_range θ1. t = t'  θ2)"
proof -
  obtain x where x: "x  subst_domain (θ1 s θ2)" "(θ1 s θ2) x = t" "t  Var x"
    using assms by (auto simp add: subst_domain_def)
  { assume "x  subst_domain θ1"
    hence "(θ1 s θ2) x = θ2 x" unfolding subst_compose_def by auto
    hence ?thesis using x by auto
  } moreover {
    assume "x  subst_domain θ1" hence ?thesis using subst_compose x(2) by fastforce 
  } ultimately show ?thesis by metis
qed

lemma subst_img_comp_subset'':
  "subtermsset (subst_range (θ1 s θ2)) 
   subtermsset (subst_range θ2)  ((subtermsset (subst_range θ1)) set θ2)"
proof
  fix t assume "t  subtermsset (subst_range (θ1 s θ2))"
  then obtain x where x: "x  subst_domain (θ1 s θ2)" "t  subterms ((θ1 s θ2) x)"
    by auto
  show "t  subtermsset (subst_range θ2)  (subtermsset (subst_range θ1) set θ2)"
  proof (cases "x  subst_domain θ1")
    case True thus ?thesis
      using subst_compose[of θ1 θ2] x(2) subterms_subst
      by fastforce
  next
    case False
    hence "(θ1 s θ2) x = θ2 x" unfolding subst_compose_def by auto
    thus ?thesis using x by (auto simp add: subst_domain_def)
  qed
qed

lemma subst_img_comp_subset''':
  "subtermsset (subst_range (θ1 s θ2)) - range Var 
   subtermsset (subst_range θ2) - range Var  ((subtermsset (subst_range θ1) - range Var) set θ2)"
proof
  fix t assume t: "t  subtermsset (subst_range (θ1 s θ2)) - range Var"
  then obtain f T where fT: "t = Fun f T" by (cases t) simp_all
  then obtain x where x: "x  subst_domain (θ1 s θ2)" "Fun f T  subterms ((θ1 s θ2) x)"
    using t by auto
  have "Fun f T  subtermsset (subst_range θ2)  (subtermsset (subst_range θ1) - range Var set θ2)"
  proof (cases "x  subst_domain θ1")
    case True
    hence "Fun f T  (subtermsset (subst_range θ2))  (subterms (θ1 x) set θ2)"
      using x(2) subterms_subst[of "θ1 x" θ2]
      unfolding subst_compose[of θ1 θ2 x] by auto
    moreover have ?thesis when *: "Fun f T  subterms (θ1 x) set θ2"
    proof -
      obtain s where s: "s  subterms (θ1 x)" "Fun f T = s  θ2" using * by moura
      show ?thesis
      proof (cases s)
        case (Var y)
        hence "Fun f T  subst_range θ2" using s by force
        thus ?thesis by blast
      next
        case (Fun g S)
        hence "Fun f T  (subterms (θ1 x) - range Var) set θ2" using s by blast
        thus ?thesis using True by auto
      qed
    qed
    ultimately show ?thesis by blast
  next
    case False
    hence "(θ1 s θ2) x = θ2 x" unfolding subst_compose_def by auto
    thus ?thesis using x by (auto simp add: subst_domain_def)
  qed
  thus "t  subtermsset (subst_range θ2) - range Var 
            (subtermsset (subst_range θ1) - range Var set θ2)"
    using fT by auto
qed

lemma subst_img_comp_subset_const:
  assumes "Fun c []  subst_range (θ1 s θ2)"
  shows "Fun c []  subst_range θ2  Fun c []  subst_range θ1 
         (x. Var x  subst_range θ1  θ2 x = Fun c [])"
proof (cases "Fun c []  subst_range θ2")
  case False
  then obtain t where t: "t  subst_range θ1" "Fun c [] = t  θ2" 
    using subst_img_comp_subset'[OF assms] by auto
  thus ?thesis by (cases t) auto
qed (simp add: subst_img_comp_subset'[OF assms])

lemma subst_img_comp_subset_const':
  fixes δ τ::"('f,'v) subst"
  assumes "(δ s τ) x = Fun c []"
  shows "δ x = Fun c []  (z. δ x = Var z  τ z = Fun c [])"
proof (cases "δ x = Fun c []")
  case False
  then obtain t where "δ x = t" "t  τ = Fun c []" using assms unfolding subst_compose_def by auto
  thus ?thesis by (cases t) auto
qed simp

lemma subst_img_comp_subset_ground:
  assumes "ground (subst_range θ1)"
  shows "subst_range (θ1 s θ2)  subst_range θ1  subst_range θ2"
proof
  fix t assume t: "t  subst_range (θ1 s θ2)"
  then obtain x where x: "x  subst_domain (θ1 s θ2)" "t = (θ1 s θ2) x" by auto

  show "t  subst_range θ1  subst_range θ2"
  proof (cases "x  subst_domain θ1")
    case True
    hence "fv (θ1 x) = {}" using assms ground_subst_range_empty_fv by fast
    hence "t = θ1 x" using x(2) unfolding subst_compose_def by blast
    thus ?thesis using True by simp
  next
    case False
    hence "t = θ2 x" "x  subst_domain θ2"
      using x subst_domain_compose[of θ1 θ2]
      by (metis subst_comp_notin_dom_eq, blast)
    thus ?thesis using x by simp
  qed
qed

lemma subst_fv_dom_img_single:
  assumes "v  fv t" "σ v = t" "w. v  w  σ w = Var w"
  shows "subst_domain σ = {v}" "range_vars σ = fv t"
proof -
  show "subst_domain σ = {v}" using assms by (fastforce simp add: subst_domain_def)
  have "fv t  range_vars σ" by (metis fv_in_subst_img assms(1,2) vars_iff_subterm_or_eq) 
  moreover have "v. σ v  Var v  σ v = t" using assms by fastforce
  ultimately show "range_vars σ = fv t"
    unfolding range_vars_alt_def
    by (auto simp add: subst_domain_def)
qed

lemma subst_comp_upd1:
  "θ(v := t) s σ = (θ s σ)(v := t  σ)"
unfolding subst_compose_def by auto

lemma subst_comp_upd2:
  assumes "v  subst_domain s" "v  range_vars s"
  shows "s(v := t) = s s (Var(v := t))"
unfolding subst_compose_def
proof -
  { fix w
    have "(s(v := t)) w = s w  Var(v := t)"
    proof (cases "w = v")
      case True
      hence "s w = Var w" using v  subst_domain s by (simp add: subst_domain_def)
      thus ?thesis using w = v by simp
    next
      case False
      hence "(s(v := t)) w = s w" by simp
      moreover have "s w  Var(v := t) = s w" using w  v v  range_vars s 
        by (metis fv_in_subst_img fun_upd_apply insert_absorb insert_subset
                  repl_invariance subst_apply_term.simps(1) subst_apply_term_empty)
      ultimately show ?thesis ..
    qed
  }
  thus "s(v := t) = (λw. s w  Var(v := t))" by auto
qed

lemma ground_subst_dom_iff_img:
  "ground (subst_range σ)  x  subst_domain σ  σ x  subst_range σ"
by (auto simp add: subst_domain_def)

lemma finite_dom_subst_exists:
  "finite S  σ::('f,'v) subst. subst_domain σ = S"
proof (induction S rule: finite.induct)
  case (insertI A a)
  then obtain σ::"('f,'v) subst" where "subst_domain σ = A" by blast
  fix f::'f
  have "subst_domain (σ(a := Fun f [])) = insert a A"
    using ‹subst_domain σ = A
    by (auto simp add: subst_domain_def)
  thus ?case by metis
qed (auto simp add: subst_domain_def)

lemma subst_inj_is_bij_betw_dom_img_if_ground_img:
  assumes "ground (subst_range σ)"
  shows "inj σ  bij_betw σ (subst_domain σ) (subst_range σ)" (is "?A  ?B")
proof
  show "?A  ?B" by (metis bij_betw_def injD inj_onI subst_range.simps)
next
  assume ?B
  hence "inj_on σ (subst_domain σ)" unfolding bij_betw_def by auto
  moreover have "x. x  UNIV - subst_domain σ  σ x = Var x" by auto
  hence "inj_on σ (UNIV - subst_domain σ)"
    using inj_onI[of "UNIV - subst_domain σ"]
    by (metis term.inject(1))
  moreover have "x y. x  subst_domain σ  y  subst_domain σ  σ x  σ y"
    using assms by (auto simp add: subst_domain_def)
  ultimately show ?A by (metis injI inj_onD subst_domI term.inject(1))
qed

lemma bij_finite_ground_subst_exists:
  assumes "finite (S::'v set)" "infinite (U::('f,'v) term set)" "ground U"
  shows "σ::('f,'v) subst. subst_domain σ = S
                           bij_betw σ (subst_domain σ) (subst_range σ)
                           subst_range σ  U"
proof -
  obtain T' where "T'  U" "card T' = card S" "finite T'"
    by (meson assms(2) finite_Diff2 infinite_arbitrarily_large)
  then obtain f::"'v  ('f,'v) term" where f_bij: "bij_betw f S T'"
    using finite_same_card_bij[OF assms(1)] by metis
  hence *: "v. v  S  f v  Var v"
    using ‹ground U T'  U bij_betwE
    by fastforce

  let  = "λv. if v  S then f v else Var v"
  have "subst_domain  = S"
  proof
    show "subst_domain   S" by (auto simp add: subst_domain_def)

    { fix v assume "v  S" "v  subst_domain "
      hence "f v = Var v" by (simp add: subst_domain_def)
      hence False using *[OF v  S] by metis
    }
    thus "S  subst_domain " by blast
  qed
  hence "v w. v  subst_domain ; w  subst_domain    w   v"
    using ‹ground U bij_betwE[OF f_bij] set_rev_mp[OF _ T'  U]
    by (metis (no_types, lifting) UN_iff empty_iff vars_iff_subterm_or_eq fvset.simps) 
  hence "inj_on  (subst_domain )"
    using f_bij ‹subst_domain  = S
    unfolding bij_betw_def inj_on_def
    by metis
  hence "bij_betw  (subst_domain ) (subst_range )"
    using inj_on_imp_bij_betw[of ] by simp
  moreover have "subst_range  = T'"
    using ‹bij_betw f S T' ‹subst_domain  = S
    unfolding bij_betw_def by auto 
  hence "subst_range   U" using T'  U by auto
  ultimately show ?thesis using ‹subst_domain  = S by (metis (lifting))
qed

lemma bij_finite_const_subst_exists:
  assumes "finite (S::'v set)" "finite (T::'f set)" "infinite (U::'f set)"
  shows "σ::('f,'v) subst. subst_domain σ = S
                           bij_betw σ (subst_domain σ) (subst_range σ)
                           subst_range σ  (λc. Fun c []) ` (U - T)"
proof -
  obtain T' where "T'  U - T" "card T' = card S" "finite T'"
    by (meson assms(2,3) finite_Diff2 infinite_arbitrarily_large)
  then obtain f::"'v  'f" where f_bij: "bij_betw f S T'"
    using finite_same_card_bij[OF assms(1)] by metis

  let  = "λv. if v  S then Fun (f v) [] else Var v"
  have "subst_domain  = S" by (simp add: subst_domain_def)
  moreover have "v w. v  subst_domain ; w  subst_domain    w   v" by auto
  hence "inj_on  (subst_domain )"
    using f_bij unfolding bij_betw_def inj_on_def
    by (metis ‹subst_domain  = S term.inject(2))
  hence "bij_betw  (subst_domain ) (subst_range )"
    using inj_on_imp_bij_betw[of ] by simp
  moreover have "subst_range  = ((λc. Fun c []) ` T')"
    using ‹bij_betw f S T' unfolding bij_betw_def inj_on_def by (auto simp add: subst_domain_def)
  hence "subst_range   ((λc. Fun c []) ` (U - T))" using T'  U - T by auto
  ultimately show ?thesis by (metis (lifting))
qed

lemma bij_finite_const_subst_exists':
  assumes "finite (S::'v set)" "finite (T::('f,'v) terms)" "infinite (U::'f set)"
  shows "σ::('f,'v) subst. subst_domain σ = S
                           bij_betw σ (subst_domain σ) (subst_range σ)
                           subst_range σ  ((λc. Fun c []) ` U) - T"
proof -
  have "finite ((funs_term ` T))" using assms(2) by auto
  then obtain σ where σ:
      "subst_domain σ = S" "bij_betw σ (subst_domain σ) (subst_range σ)"
      "subst_range σ  (λc. Fun c []) ` (U - ((funs_term ` T)))"
    using bij_finite_const_subst_exists[OF assms(1) _ assms(3)] by blast
  moreover have "(λc. Fun c []) ` (U - ((funs_term ` T)))  ((λc. Fun c []) ` U) - T" by auto
  ultimately show ?thesis by blast
qed

lemma bij_betw_iteI:
  assumes "bij_betw f A B" "bij_betw g C D" "A  C = {}" "B  D = {}"
  shows "bij_betw (λx. if x  A then f x else g x) (A  C) (B  D)"
proof -
  have "bij_betw (λx. if x  A then f x else g x) A B"
    by (metis bij_betw_cong[of A f "λx. if x  A then f x else g x" B] assms(1))
  moreover have "bij_betw (λx. if x  A then f x else g x) C D"
    using bij_betw_cong[of C g "λx. if x  A then f x else g x" D] assms(2,3) by force
  ultimately show ?thesis using bij_betw_combine[OF _ _ assms(4)] by metis
qed

lemma subst_comp_split:
  assumes "subst_domain θ  range_vars θ = {}"
  shows "θ = (rm_vars (subst_domain θ - V) θ) s (rm_vars V θ)" (is ?P)
    and "θ = (rm_vars V θ) s (rm_vars (subst_domain θ - V) θ)" (is ?Q)
proof -
  let ?rm1 = "rm_vars (subst_domain θ - V) θ" and ?rm2 = "rm_vars V θ"
  have "subst_domain ?rm2  range_vars ?rm1 = {}"
       "subst_domain ?rm1  range_vars ?rm2 = {}"
    using assms unfolding range_vars_alt_def by (force simp add: subst_domain_def)+
  hence *: "v. v  subst_domain ?rm1  (?rm1 s ?rm2) v = θ v"
           "v. v  subst_domain ?rm2  (?rm2 s ?rm1) v = θ v"
    using ident_comp_subst_trm_if_disj[of ?rm2 ?rm1]
          ident_comp_subst_trm_if_disj[of ?rm1 ?rm2]
    by (auto simp add: subst_domain_def)
  hence "v. v  subst_domain ?rm1  (?rm1 s ?rm2) v = θ v"
        "v. v  subst_domain ?rm2  (?rm2 s ?rm1) v = θ v"
    unfolding subst_compose_def by (auto simp add: subst_domain_def)
  hence "v. (?rm1 s ?rm2) v = θ v" "v. (?rm2 s ?rm1) v = θ v" using * by blast+
  thus ?P ?Q by auto
qed

lemma subst_comp_eq_if_disjoint_vars:
  assumes "(subst_domain δ  range_vars δ)  (subst_domain γ  range_vars γ) = {}"
  shows "γ s δ = δ s γ"
proof -
  { fix x assume "x  subst_domain γ"
    hence "(γ s δ) x = γ x" "(δ s γ) x = γ x"
      using assms unfolding range_vars_alt_def by (force simp add: subst_compose)+
    hence "(γ s δ) x = (δ s γ) x" by metis
  } moreover
  { fix x assume "x  subst_domain δ"
    hence "(γ s δ) x = δ x" "(δ s γ) x = δ x"
      using assms
      unfolding range_vars_alt_def by (auto simp add: subst_compose subst_domain_def)
    hence "(γ s δ) x = (δ s γ) x" by metis
  } moreover
  { fix x assume "x  subst_domain γ" "x  subst_domain δ"
    hence "(γ s δ) x = (δ s γ) x" by (simp add: subst_compose subst_domain_def)
  } ultimately show ?thesis by auto
qed

lemma subst_eq_if_disjoint_vars_ground:
  fixes ξ δ::"('f,'v) subst"
  assumes "subst_domain δ  subst_domain ξ = {}" "ground (subst_range ξ)" "ground (subst_range δ)" 
  shows "t  δ  ξ = t  ξ  δ"
by (metis assms subst_comp_eq_if_disjoint_vars range_vars_alt_def
          subst_subst_compose sup_bot.right_neutral)

lemma subst_img_bound: "subst_domain δ  range_vars δ  fv t  range_vars δ  fv (t  δ)"
proof -
  assume "subst_domain δ  range_vars δ  fv t"
  hence "subst_domain δ  fv t" by blast
  thus ?thesis
    by (metis (no_types) range_vars_alt_def le_iff_sup subst_apply_fv_unfold
              subst_apply_fv_union subst_range.simps)
qed

lemma subst_all_fv_subset: "fv t  fvset M  fv (t  θ)  fvset (M set θ)"
proof -
  assume *: "fv t  fvset M"
  { fix v assume "v  fv t"
    hence "v  fvset M" using * by auto
    then obtain t' where "t'  M" "v  fv t'" by auto
    hence "fv (θ v)  fv (t'  θ)"
      by (metis subst_apply_term.simps(1) subst_apply_fv_subset subst_apply_fv_unfold
                subtermeq_vars_subset vars_iff_subtermeq) 
    hence "fv (θ v)  fvset (M set θ)" using t'  M by auto
  }
  thus ?thesis using subst_apply_fv_unfold[of t θ] by auto
qed

lemma subst_support_if_mgt_subst_idem:
  assumes "θ  δ" "subst_idem θ"
  shows "θ supports δ"
proof -
  from θ  δ obtain σ where σ: "δ = θ s σ" by blast
  hence "v. θ v  δ = Var v  (θ s θ s σ)" by simp
  hence "v. θ v  δ = Var v  (θ s σ)" using ‹subst_idem θ unfolding subst_idem_def by simp
  hence "v. θ v  δ = Var v  δ" using σ by simp
  thus "θ supports δ" by simp
qed

lemma subst_support_iff_mgt_if_subst_idem:
  assumes "subst_idem θ"
  shows "θ  δ  θ supports δ"
proof
  show "θ  δ  θ supports δ" by (fact subst_support_if_mgt_subst_idem[OF _ ‹subst_idem θ])
  show "θ supports δ  θ  δ" by (fact subst_supportD)
qed

lemma subst_support_comp:
  fixes θ δ ::"('a,'b) subst"
  assumes "θ supports " "δ supports "
  shows "(θ s δ) supports "
by (metis (no_types) assms subst_agreement subst_apply_term.simps(1) subst_subst_compose)

lemma subst_support_comp':
  fixes θ δ σ::"('a,'b) subst"
  assumes "θ supports δ"
  shows "θ supports (δ s σ)" "σ supports δ  θ supports (σ s δ)"
using assms unfolding subst_support_def by (metis subst_compose_assoc, metis)

lemma subst_support_comp_split:
  fixes θ δ ::"('a,'b) subst"
  assumes "(θ s δ) supports "
  shows "subst_domain θ  range_vars θ = {}  θ supports "
  and "subst_domain θ  subst_domain δ = {}  δ supports "
proof -
  assume "subst_domain θ  range_vars θ = {}"
  hence "subst_idem θ" by (metis subst_idemI)
  have "θ  " using assms subst_compose_assoc[of θ δ ] unfolding subst_compose_def by metis
  show "θ supports " using subst_support_if_mgt_subst_idem[OF θ   ‹subst_idem θ] by auto
next
  assume "subst_domain θ  subst_domain δ = {}"
  moreover have "v  subst_domain (θ s δ). (θ s δ) v   =  v" using assms by metis
  ultimately have "v  subst_domain δ. δ v   =  v"
    using var_not_in_subst_dom unfolding subst_compose_def
    by (metis IntI empty_iff subst_apply_term.simps(1))
  thus "δ supports " by force
qed

lemma subst_idem_support: "subst_idem θ  θ supports θ s δ"
unfolding subst_idem_def by (metis subst_support_def subst_compose_assoc)

lemma subst_idem_iff_self_support: "subst_idem θ  θ supports θ"
using subst_support_def[of θ θ] unfolding subst_idem_def by auto

lemma subterm_subst_neq: "t  t'  t  s  t'  s"
by (metis subst_mono_neq)

lemma fv_Fun_subst_neq: "x  fv (Fun f T)  σ x  Fun f T  σ"
using subterm_subst_neq[of "Var x" "Fun f T"] vars_iff_subterm_or_eq[of x "Fun f T"] by auto

lemma subterm_subst_unfold:
  assumes "t  s  θ"
  shows "(s'. s'  s  t = s'  θ)  (x  fv s. t  θ x)"
using assms
proof (induction s)
  case (Fun f T) thus ?case
  proof (cases "t = Fun f T  θ")
    case True thus ?thesis using Fun by auto
  next
    case False
    then obtain s' where s': "s'  set T" "t  s'  θ" using Fun by auto
    hence "(s''. s''  s'  t = s''  θ)  (x  fv s'. t  θ x)" by (metis Fun.IH)
    thus ?thesis using s'(1) by auto
  qed
qed simp

lemma subterm_subst_img_subterm:
  assumes "t  s  θ" "s'. s'  s  t  s'  θ"
  shows "w  fv s. t  θ w"
using subterm_subst_unfold[OF assms(1)] assms(2) by force

lemma subterm_subst_not_img_subterm:
  assumes "t  s  " "¬(w  fv s. t   w)"
  shows "f T. Fun f T  s  t = Fun f T  "
proof (rule ccontr)
  assume "¬(f T. Fun f T  s  t = Fun f T  )"
  hence "f T. Fun f T  s  t  Fun f T  " by simp
  moreover have "x. Var x  s  t  Var x  "
    using assms(2) vars_iff_subtermeq by force
  ultimately have "s'. s'  s  t  s'  " by (metis "term.exhaust")
  thus False using assms subterm_subst_img_subterm by blast
qed

lemma subst_apply_img_var:
  assumes "v  fv (t  δ)" "v  fv t"
  obtains w where "w  fv t" "v  fv (δ w)"
using assms by (induct t) auto

lemma subst_apply_img_var':
  assumes "x  fv (t  δ)" "x  fv t"
  shows "y  fv t. x  fv (δ y)"
by (metis assms subst_apply_img_var)

lemma nth_map_subst:
  fixes θ::"('f,'v) subst" and T::"('f,'v) term list" and i::nat
  shows "i < length T  (map (λt. t  θ) T) ! i = (T ! i)  θ"
by (fact nth_map)

lemma subst_subterm:
  assumes "Fun f T  t  θ"
  shows "(S. Fun f S  t  Fun f S  θ = Fun f T) 
         (s  subst_range θ. Fun f T  s)"
using assms subterm_subst_not_img_subterm by (cases "s  subst_range θ. Fun f T  s") fastforce+

lemma subst_subterm':
  assumes "Fun f T  t  θ"
  shows "S. length S = length T  (Fun f S  t  (s  subst_range θ. Fun f S  s))"
using subst_subterm[OF assms] by auto

lemma subst_subterm'':
  assumes "s  subterms (t  θ)"
  shows "(u  subterms t. s = u  θ)  s  subtermsset (subst_range θ)"
proof (cases s)
  case (Var x)
  thus ?thesis
    using assms subterm_subst_not_img_subterm vars_iff_subtermeq
    by (cases "s = t  θ") fastforce+
next
  case (Fun f T)
  thus ?thesis
    using subst_subterm[of f T t θ] assms
    by fastforce
qed


subsection ‹More Small Lemmata›
lemma funs_term_subst: "funs_term (t  θ) = funs_term t  (x  fv t. funs_term (θ x))"
by (induct t) auto

lemma fvset_subst_img_eq:
  assumes "X  (subst_domain δ  range_vars δ) = {}"
  shows "fvset (δ ` (Y - X)) = fvset (δ ` Y) - X"
using assms unfolding range_vars_alt_def by force

lemma subst_Fun_index_eq:
  assumes "i < length T" "Fun f T  δ = Fun g T'  δ"
  shows "T ! i  δ = T' ! i  δ"
proof -
  have "map (λx. x  δ) T = map (λx. x  δ) T'" using assms by simp
  thus ?thesis by (metis assms(1) length_map nth_map)
qed

lemma fv_exists_if_unifiable_and_neq:
  fixes t t'::"('a,'b) term" and δ θ::"('a,'b) subst"
  assumes "t  t'" "t  θ = t'  θ"
  shows "fv t  fv t'  {}"
proof
  assume "fv t  fv t' = {}"
  hence "fv t = {}" "fv t' = {}" by auto
  hence "t  θ = t" "t'  θ = t'" by auto
  hence "t = t'" using assms(2) by metis
  thus False using assms(1) by auto
qed

lemma const_subterm_subst: "Fun c []  t  Fun c []  t  σ"
by (induct t) auto

lemma const_subterm_subst_var_obtain:
  assumes "Fun c []  t  σ" "¬Fun c []  t"
  obtains x where "x  fv t" "Fun c []  σ x"
using assms by (induct t) auto

lemma const_subterm_subst_cases:
  assumes "Fun c []  t  σ"
  shows "Fun c []  t  (x  fv t. x  subst_domain σ  Fun c []  σ x)"
proof (cases "Fun c []  t")
  case False
  then obtain x where "x  fv t" "Fun c []  σ x"
    using const_subterm_subst_var_obtain[OF assms] by moura
  thus ?thesis by (cases "x  subst_domain σ") auto
qed simp

lemma fvpairs_subst_fv_subset:
  assumes "x  fvpairs F"
  shows "fv (θ x)  fvpairs (F pairs θ)"
  using assms
proof (induction F)
  case (Cons f F)
  then obtain t t' where f: "f = (t,t')" by (metis surj_pair)
  show ?case
  proof (cases "x  fvpairs F")
    case True thus ?thesis
      using Cons.IH
      unfolding subst_apply_pairs_def
      by auto
  next
    case False
    hence "x  fv t  fv t'" using Cons.prems f by simp
    hence "fv (θ x)  fv (t  θ)  fv (t'  θ)" using fv_subst_subset[of x] by force
    thus ?thesis using f unfolding subst_apply_pairs_def by auto
  qed
qed simp

lemma fvpairs_step_subst: "fvset (δ ` fvpairs F) = fvpairs (F pairs δ)"
proof (induction F)
  case (Cons f F)
  obtain t t' where "f = (t,t')" by moura
  thus ?case
    using Cons
    by (simp add: subst_apply_pairs_def subst_apply_fv_unfold)
qed (simp_all add: subst_apply_pairs_def)

lemma fvpairs_subst_obtain_var:
  fixes δ::"('a,'b) subst"
  assumes "x  fvpairs (F pairs δ)"
  shows "y  fvpairs F. x  fv (δ y)"
  using assms 
proof (induction F)
  case (Cons f F)
  then obtain t s where f: "f = (t,s)" by (metis surj_pair)

  from Cons.IH show ?case
  proof (cases "x  fvpairs (F pairs δ)")
    case False
    hence "x  fv (t  δ)  x  fv (s  δ)"
      using f Cons.prems
      by (simp add: subst_apply_pairs_def)
    hence "(y  fv t. x  fv (δ y))  (y  fv s. x  fv (δ y))" by (metis fv_subst_obtain_var)
    thus ?thesis using f by (auto simp add: subst_apply_pairs_def)
  qed (auto simp add: Cons.IH)
qed (simp add: subst_apply_pairs_def)

lemma pair_subst_ident[intro]: "(fv t  fv t')  subst_domain θ = {}  (t,t') p θ = (t,t')"
by auto

lemma pairs_substI[intro]:
  assumes "subst_domain θ  ((s,t)  M. fv s  fv t) = {}"
  shows "M pset θ = M"
proof -
  { fix m assume M: "m  M"
    then obtain s t where m: "m = (s,t)" by (metis surj_pair)
    hence "(fv s  fv t)  subst_domain θ = {}" using assms M by auto
    hence "m p θ = m" using m by auto
  } thus ?thesis by (simp add: image_cong) 
qed

lemma fvpairs_subst: "fvpairs (F pairs θ) = fvset (θ ` (fvpairs F))"
proof (induction F)
  case (Cons g G)
  obtain t t' where "g = (t,t')" by (metis surj_pair)
  thus ?case
    using Cons.IH
    by (simp add: subst_apply_pairs_def subst_apply_fv_unfold)
qed (simp add: subst_apply_pairs_def)

lemma fvpairs_subst_subset:
  assumes "fvpairs (F pairs δ)  subst_domain σ"
  shows  "fvpairs F  subst_domain σ  subst_domain δ"
  using assms
proof (induction F)
  case (Cons g G)
  hence IH: "fvpairs G  subst_domain σ  subst_domain δ"
    by (simp add: subst_apply_pairs_def)
  obtain t t' where g: "g = (t,t')" by (metis surj_pair)
  hence "fv (t  δ)  subst_domain σ" "fv (t'  δ)  subst_domain σ"
    using Cons.prems by (simp_all add: subst_apply_pairs_def)
  hence "fv t  subst_domain σ  subst_domain δ" "fv t'  subst_domain σ  subst_domain δ"
    using subst_apply_fv_unfold[of _ δ] by force+
  thus ?case using IH g by (simp add: subst_apply_pairs_def)
qed (simp add: subst_apply_pairs_def)

lemma pairs_subst_comp: "F pairs δ s θ = ((F pairs δ) pairs θ)"
by (induct F) (auto simp add: subst_apply_pairs_def)

lemma pairs_substI'[intro]:
  "subst_domain θ  fvpairs F = {}  F pairs θ = F"
by (induct F) (force simp add: subst_apply_pairs_def)+

lemma subst_pair_compose[simp]: "d p (δ s ) = d p δ p "
proof -
  obtain t s where "d = (t,s)" by moura
  thus ?thesis by auto
qed

lemma subst_pairs_compose[simp]: "D pset (δ s ) = D pset δ pset "
by auto

lemma subst_apply_pair_pair: "(t, s) p  = (t  , s  )"
by (rule prod.case)

lemma subst_apply_pairs_nil[simp]: "[] pairs δ = []"
unfolding subst_apply_pairs_def by simp

lemma subst_apply_pairs_singleton[simp]: "[(t,s)] pairs δ = [(t  δ,s  δ)]"
unfolding subst_apply_pairs_def by simp

lemma subst_apply_pairs_Var[iff]: "F pairs Var = F" by (simp add: subst_apply_pairs_def)

lemma subst_apply_pairs_pset_subst: "set (F pairs θ) = set F pset θ"
unfolding subst_apply_pairs_def by force


subsection ‹Finite Substitutions›
inductive_set fsubst::"('a,'b) subst set" where
  fvar:     "Var  fsubst"
| FUpdate:  "θ  fsubst; v  subst_domain θ; t  Var v  θ(v := t)  fsubst"

lemma finite_dom_iff_fsubst:
  "finite (subst_domain θ)  θ  fsubst"
proof
  assume "finite (subst_domain θ)" thus "θ  fsubst"
  proof (induction "subst_domain θ" arbitrary: θ rule: finite.induct)
    case emptyI
    hence "θ = Var" using empty_dom_iff_empty_subst by metis
    thus ?case using fvar by simp
  next
    case (insertI θ'dom v) thus ?case
    proof (cases "v  θ'dom")
      case True
      hence "θ'dom = subst_domain θ" using ‹insert v θ'dom = subst_domain θ by auto
      thus ?thesis using insertI.hyps(2) by metis
    next
      case False
      let ?θ' = "λw. if w  θ'dom then θ w else Var w"
      have "subst_domain ?θ' = θ'dom"
        using v  θ'dom ‹insert v θ'dom = subst_domain θ
        by (auto simp add: subst_domain_def)
      hence "?θ'  fsubst" using insertI.hyps(2) by simp
      moreover have "?θ'(v := θ v) = (λw. if w  insert v θ'dom then θ w else Var w)" by auto
      hence "?θ'(v := θ v) = θ"
        using ‹insert v θ'dom = subst_domain θ
        by (auto simp add: subst_domain_def)
      ultimately show ?thesis
        using FUpdate[of ?θ' v "θ v"] False insertI.hyps(3)
        by (auto simp add: subst_domain_def)
    qed
  qed
next
  assume "θ  fsubst" thus "finite (subst_domain θ)"
  by (induct θ, simp, metis subst_dom_insert_finite)
qed

lemma fsubst_induct[case_names fvar FUpdate, induct set: finite]:
  assumes "finite (subst_domain δ)" "P Var"
  and "θ v t. finite (subst_domain θ); v  subst_domain θ; t  Var v; P θ  P (θ(v := t))"
  shows "P δ"
using assms finite_dom_iff_fsubst fsubst.induct by metis

lemma fun_upd_fsubst: "s(v := t)  fsubst  s  fsubst"
using subst_dom_insert_finite[of s] finite_dom_iff_fsubst by blast 

lemma finite_img_if_fsubst: "s  fsubst  finite (subst_range s)"
using finite_dom_iff_fsubst finite_subst_img_if_finite_dom' by blast


subsection ‹Unifiers and Most General Unifiers (MGUs)›

abbreviation Unifier::"('f,'v) subst  ('f,'v) term  ('f,'v) term  bool" where
  "Unifier σ t u  (t  σ = u  σ)"

abbreviation MGU::"('f,'v) subst  ('f,'v) term  ('f,'v) term  bool" where
  "MGU σ t u  Unifier σ t u  (θ. Unifier θ t u  σ  θ)"

lemma MGUI[intro]:
  shows "t  σ = u  σ; θ::('f,'v) subst. t  θ = u  θ  σ  θ  MGU σ t u"
by auto

lemma UnifierD[dest]:
  fixes σ::"('f,'v) subst" and f g::'f and X Y::"('f,'v) term list"
  assumes "Unifier σ (Fun f X) (Fun g Y)"
  shows "f = g" "length X = length Y"
proof -
  from assms show "f = g" by auto

  from assms have "Fun f X  σ = Fun g Y  σ" by auto
  hence "length (map (λx. x  σ) X) = length (map (λx. x  σ) Y)" by auto
  thus "length X = length Y" by auto
qed

lemma MGUD[dest]:
  fixes σ::"('f,'v) subst" and f g::'f and X Y::"('f,'v) term list"
  assumes "MGU σ (Fun f X) (Fun g Y)"
  shows "f = g" "length X = length Y"
using assms by (auto intro!: UnifierD[of f X σ g Y])

lemma MGU_sym[sym]: "MGU σ s t  MGU σ t s" by auto
lemma Unifier_sym[sym]: "Unifier σ s t  Unifier σ t s" by auto

lemma MGU_nil: "MGU Var s t  s = t" by fastforce

lemma Unifier_comp: "Unifier (θ s δ) t u  Unifier δ (t  θ) (u  θ)"
by simp

lemma Unifier_comp': "Unifier δ (t  θ) (u  θ)  Unifier (θ s δ) t u"
by simp

lemma Unifier_excludes_subterm:
  assumes θ: "Unifier θ t u"
  shows "¬t  u"
proof
  assume "t  u"
  hence "t  θ  u  θ" using subst_mono_neq by metis
  hence "t  θ  u  θ" by simp
  moreover from θ have "t  θ = u  θ" by auto
  ultimately show False ..
qed

lemma MGU_is_Unifier: "MGU σ t u  Unifier σ t u" by (rule conjunct1)

lemma MGU_Var1:
  assumes "¬Var v  t"
  shows "MGU (Var(v := t)) (Var v) t"
proof (intro MGUI exI)
  show "Var v  (Var(v := t)) = t  (Var(v := t))" using assms subst_no_occs by fastforce
next
  fix θ::"('a,'b) subst" assume th: "Var v  θ = t  θ" 
  show "θ = (Var(v := t)) s θ" 
  proof
    fix s show "s  θ = s  ((Var(v := t)) s θ)" using th by (induct s) auto
  qed
qed

lemma MGU_Var2: "v  fv t  MGU (Var(v := t)) (Var v) t"
by (metis (no_types) MGU_Var1 vars_iff_subterm_or_eq)

lemma MGU_Var3: "MGU Var (Var v) (Var w)  v = w" by fastforce

lemma MGU_Const1: "MGU Var (Fun c []) (Fun d [])  c = d" by fastforce

lemma MGU_Const2: "MGU θ (Fun c []) (Fun d [])  c = d" by auto

lemma MGU_Fun:
  assumes "MGU θ (Fun f X) (Fun g Y)"
  shows "f = g" "length X = length Y"
proof -
  let ?F = "λθ X. map (λx. x  θ) X"
  from assms have
    "f = g; ?F θ X = ?F θ Y; θ'. f = g  ?F θ' X = ?F θ' Y  θ  θ'  length X = length Y"
    using map_eq_imp_length_eq by auto
  thus "f = g" "length X = length Y" using assms by auto
qed

lemma Unifier_Fun:
  assumes "Unifier θ (Fun f (x#X)) (Fun g (y#Y))"
  shows "Unifier θ x y" "Unifier θ (Fun f X) (Fun g Y)"
using assms by simp_all

lemma Unifier_subst_idem_subst: 
  "subst_idem r  Unifier s (t  r) (u  r)  Unifier (r s s) (t  r) (u  r)"
by (metis (no_types, lifting) subst_idem_def subst_subst_compose)

lemma subst_idem_comp:
  "subst_idem r  Unifier s (t  r) (u  r)  
    (q. Unifier q (t  r) (u  r)  s s q = q) 
    subst_idem (r s s)"
by (frule Unifier_subst_idem_subst, blast, metis subst_idem_def subst_compose_assoc)

lemma Unifier_mgt: "Unifier δ t u; δ  θ  Unifier θ t u" by auto

lemma Unifier_support: "Unifier δ t u; δ supports θ  Unifier θ t u"
using subst_supportD Unifier_mgt by metis

lemma MGU_mgt: "MGU σ t u; MGU δ t u  σ  δ" by auto

lemma Unifier_trm_fv_bound:
  "Unifier s t u; v  fv t  v  subst_domain s  range_vars s  fv u"
proof (induction t arbitrary: s u)
  case (Fun f X)
  hence "v  fv (u  s)  v  subst_domain s" by (metis subst_not_dom_fixed)
  thus ?case by (metis (no_types) Un_iff contra_subsetD subst_sends_fv_to_img)
qed (metis (no_types) UnI1 UnI2 subsetCE no_var_subterm subst_sends_dom_to_img
            subst_to_var_is_var trm_subst_ident' vars_iff_subterm_or_eq)

lemma Unifier_rm_var: "Unifier θ s t; v  fv s  fv t  Unifier (rm_var v θ) s t"
by (auto simp add: repl_invariance)

lemma Unifier_ground_rm_vars:
  assumes "ground (subst_range s)" "Unifier (rm_vars X s) t t'"
  shows "Unifier s t t'"
by (rule Unifier_support[OF assms(2) rm_vars_ground_supports[OF assms(1)]])

lemma Unifier_dom_restrict:
  assumes "Unifier s t t'" "fv t  fv t'  S"
  shows "Unifier (rm_vars (UNIV - S) s) t t'"
proof -
  let ?s = "rm_vars (UNIV - S) s"
  show ?thesis using term_subst_eq_conv[of t s ?s] term_subst_eq_conv[of t' s ?s] assms by auto
qed


subsection ‹Well-formedness of Substitutions and Unifiers›
inductive_set wfsubst_set::"('a,'b) subst set" where
  Empty[simp]: "Var  wfsubst_set"
| Insert[simp]:
    "θ  wfsubst_set; v  subst_domain θ;
      v  range_vars θ; fv t  (insert v (subst_domain θ)) = {}
       θ(v := t)  wfsubst_set"

definition wfsubst::"('a,'b) subst  bool" where
  "wfsubst θ  subst_domain θ  range_vars θ = {}  finite (subst_domain θ)"

definition wfMGU::"('a,'b) subst  ('a,'b) term  ('a,'b) term  bool" where
  "wfMGU θ s t  wfsubst θ  MGU θ s t  subst_domain θ  range_vars θ  fv s  fv t"

lemma wf_subst_subst_idem: "wfsubst θ  subst_idem θ" using subst_idemI[of θ] unfolding wfsubst_def by fast

lemma wf_subst_properties: "θ  wfsubst_set = wfsubst θ"
proof
  show "wfsubst θ  θ  wfsubst_set" unfolding wfsubst_def
  proof -
    assume "subst_domain θ  range_vars θ = {}  finite (subst_domain θ)"
    hence "finite (subst_domain θ)" "subst_domain θ  range_vars θ = {}"
      by auto
    thus "θ  wfsubst_set"
    proof (induction θ rule: fsubst_induct)
      case fvar thus ?case by simp
    next
      case (FUpdate δ v t)
      have "subst_domain δ  subst_domain (δ(v := t))" "range_vars δ  range_vars (δ(v := t))"
        using FUpdate.hyps(2,3) subst_img_update
        unfolding range_vars_alt_def by (fastforce simp add: subst_domain_def)+
      hence "subst_domain δ  range_vars δ = {}" using FUpdate.prems(1) by blast
      hence "δ  wfsubst_set" using FUpdate.IH by metis

      have *: "range_vars (δ(v := t)) = range_vars δ  fv t"
        using FUpdate.hyps(2) subst_img_update[OF _ FUpdate.hyps(3)]
        by fastforce
      hence "fv t  insert v (subst_domain δ) = {}"
        using FUpdate.prems subst_dom_update2[OF FUpdate.hyps(3)] by blast
      moreover have "subst_domain (δ(v := t)) = insert v (subst_domain δ)"
        by (meson FUpdate.hyps(3) subst_dom_update2)
      hence "v  range_vars δ" using FUpdate.prems * by blast
      ultimately show ?case using Insert[OF δ  wfsubst_set› v  subst_domain δ] by metis
    qed
  qed

  show "θ  wfsubst_set  wfsubst θ" unfolding wfsubst_def
  proof (induction θ rule: wfsubst_set.induct)
    case Empty thus ?case by simp
  next
    case (Insert σ v t)
    hence 1: "subst_domain σ  range_vars σ = {}" by simp
    hence 2: "subst_domain (σ(v := t))  range_vars σ = {}"
      using Insert.hyps(3) by (auto simp add: subst_domain_def)
    have 3: "fv t  subst_domain (σ(v := t)) = {}"
      using Insert.hyps(4) by (auto simp add: subst_domain_def)
    have 4: "σ v = Var v" using v  subst_domain σ by (simp add: subst_domain_def)
  
    from Insert.IH have "finite (subst_domain σ)" by simp
    hence 5: "finite (subst_domain (σ(v := t)))" using subst_dom_insert_finite[of σ] by simp
  
    have "subst_domain (σ(v := t))  range_vars (σ(v := t)) = {}"
    proof (cases "t = Var v")
      case True
      hence "range_vars (σ(v := t)) = range_vars σ"
        using 4 fun_upd_triv term.inject(1)
        unfolding range_vars_alt_def by (auto simp add: subst_domain_def) 
      thus "subst_domain (σ(v := t))  range_vars (σ(v := t)) = {}"
        using 1 2 3 by auto
    next
      case False
      hence "range_vars (σ(v := t)) = fv t  (range_vars σ)"
        using 4 subst_img_update[of σ v] by auto
      thus "subst_domain (σ(v := t))  range_vars (σ(v := t)) = {}" using 1 2 3 by blast
    qed
    thus ?case using 5 by blast 
  qed
qed

lemma wfsubst_induct[consumes 1, case_names Empty Insert]:
  assumes "wfsubst δ" "P Var"
  and "θ v t. wfsubst θ; P θ; v  subst_domain θ; v  range_vars θ;
                fv t  insert v (subst_domain θ) = {}
                 P (θ(v := t))"
  shows "P δ"
proof -
  from assms(1,3) wf_subst_properties have
    "δ  wfsubst_set"
    "θ v t. θ  wfsubst_set; P θ; v  subst_domain θ; v  range_vars θ;
              fv t  insert v (subst_domain θ) = {}
               P (θ(v := t))"
    by blast+
  thus "P δ" using wfsubst_set.induct assms(2) by blast
qed  

lemma wf_subst_fsubst: "wfsubst δ  δ  fsubst"
unfolding wfsubst_def using finite_dom_iff_fsubst by blast 

lemma wf_subst_nil: "wfsubst Var" unfolding wfsubst_def by simp

lemma wf_MGU_nil: "MGU Var s t  wfMGU Var s t"
using wf_subst_nil subst_domain_Var range_vars_Var
unfolding wfMGU_def by fast

lemma wf_MGU_dom_bound: "wfMGU θ s t  subst_domain θ  fv s  fv t" unfolding wfMGU_def by blast

lemma wf_subst_single:
  assumes "v  fv t" "σ v = t" "w. v  w  σ w = Var w"
  shows "wfsubst σ"
proof -
  have *: "subst_domain σ = {v}" by (metis subst_fv_dom_img_single(1)[OF assms])

  have "subst_domain σ  range_vars σ = {}"
    using * assms subst_fv_dom_img_single(2)
    by (metis inf_bot_left insert_disjoint(1))
  moreover have "finite (subst_domain σ)" using * by simp
  ultimately show ?thesis by (metis wfsubst_def)
qed

lemma wf_subst_reduction:
  "wfsubst s  wfsubst (rm_var v s)"
proof -
  assume "wfsubst s"
  moreover have "subst_domain (rm_var v s)  subst_domain s" by (auto simp add: subst_domain_def)
  moreover have "range_vars (rm_var v s)  range_vars s"
    unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
  ultimately have "subst_domain (rm_var v s)  range_vars (rm_var v s) = {}"
    by (meson compl_le_compl_iff disjoint_eq_subset_Compl subset_trans wfsubst_def)
  moreover have "finite (subst_domain (rm_var v s))"
    using ‹subst_domain (rm_var v s)  subst_domain s ‹wfsubst s rev_finite_subset
    unfolding wfsubst_def by blast
  ultimately show "wfsubst (rm_var v s)" by (metis wfsubst_def)
qed

lemma wf_subst_compose:
  assumes "wfsubst θ1" "wfsubst θ2"
    and "subst_domain θ1  subst_domain θ2 = {}"
    and "subst_domain θ1  range_vars θ2 = {}"
  shows "wfsubst (θ1 s θ2)"
using assms
proof (induction θ1 rule: wfsubst_induct)
  case Empty thus ?case unfolding wfsubst_def by simp
next
  case (Insert σ1 v t)
  have "t  Var v" using Insert.hyps(4) by auto
  hence dom1v_unfold: "subst_domain (σ1(v := t)) = insert v (subst_domain σ1)"
    using subst_dom_update2 by metis
  hence doms_disj: "subst_domain σ1  subst_domain θ2 = {}" 
    using Insert.prems(2) disjoint_insert(1) by blast
  moreover have dom_img_disj: "subst_domain σ1  range_vars θ2 = {}"
    using Insert.hyps(2) Insert.prems(3)
    by (fastforce simp add: subst_domain_def)
  ultimately have "wfsubst (σ1 s θ2)" using Insert.IH[OF ‹wfsubst θ2] by metis

  have dom_comp_is_union: "subst_domain (σ1 s θ2) = subst_domain σ1  subst_domain θ2"
    using subst_dom_comp_eq[OF dom_img_disj] .

  have "v  subst_domain θ2"
    using Insert.prems(2) t  Var v
    by (fastforce simp add: subst_domain_def)
  hence "θ2 v = Var v" "σ1 v = Var v" using Insert.hyps(2) by (simp_all add: subst_domain_def)
  hence "(σ1 s θ2) v = Var v" "(σ1(v := t) s θ2) v = t  θ2" "((σ1 s θ2)(v := t)) v = t"
    unfolding subst_compose_def by simp_all
  
  have fv_t2_bound: "fv (t  θ2)  fv t  range_vars θ2" by (meson subst_sends_fv_to_img)

  have 1: "v  subst_domain (σ1 s θ2)"
    using (σ1 s θ2) v = Var v
    by (auto simp add: subst_domain_def)

  have "insert v (subst_domain σ1)  range_vars θ2 = {}"
    using Insert.prems(3) dom1v_unfold by blast
  hence "v  range_vars σ1  range_vars θ2" using Insert.hyps(3) by blast
  hence 2: "v  range_vars (σ1 s θ2)" by (meson set_rev_mp subst_img_comp_subset)

  have "subst_domain θ2  range_vars θ2 = {}"
    using ‹wfsubst θ2 unfolding wfsubst_def by simp
  hence "fv (t  θ2)  subst_domain θ2 = {}"
    using subst_dom_elim unfolding range_vars_alt_def by simp
  moreover have "v  range_vars θ2" using Insert.prems(3) dom1v_unfold by blast
  hence "v  fv t  range_vars θ2" using Insert.hyps(4) by blast
  hence "v  fv (t  θ2)" using ‹fv (t  θ2)  fv t  range_vars θ2 by blast
  moreover have "fv (t  θ2)  subst_domain σ1 = {}"
    using dom_img_disj fv_t2_bound ‹fv t  insert v (subst_domain σ1) = {} by blast
  ultimately have 3: "fv (t  θ2)  insert v (subst_domain (σ1 s θ2)) = {}"
    using dom_comp_is_union by blast

  have "σ1(v := t) s θ2 = (σ1 s θ2)(v := t  θ2)" using subst_comp_upd1[of σ1 v t θ2] .
  moreover have "wfsubst ((σ1 s θ2)(v := t  θ2))"
    using "wfsubst_set.Insert"[OF _ 1 2 3] ‹wfsubst (σ1 s θ2) wf_subst_properties by metis
  ultimately show ?case by presburger
qed

lemma wf_subst_append:
  fixes θ1 θ2::"('f,'v) subst"
  assumes "wfsubst θ1" "wfsubst θ2"
    and "subst_domain θ1  subst_domain θ2 = {}"
    and "subst_domain θ1  range_vars θ2 = {}"
    and "range_vars θ1  subst_domain θ2 = {}"
  shows "wfsubst (λv. if θ1 v = Var v then θ2 v else θ1 v)"
using assms
proof (induction θ1 rule: wfsubst_induct)
  case Empty thus ?case unfolding wfsubst_def by simp
next
  case (Insert σ1 v t)
  let ?if = "λw. if σ1 w = Var w then θ2 w else σ1 w"
  let ?if_upd = "λw. if (σ1(v := t)) w = Var w then θ2 w else (σ1(v := t)) w"

  from Insert.hyps(4) have "?if_upd = ?if(v := t)" by fastforce

  have dom_insert: "subst_domain (σ1(v := t)) = insert v (subst_domain σ1)"
    using Insert.hyps(4) by (auto simp add: subst_domain_def)

  have "σ1 v = Var v" "t  Var v" using Insert.hyps(2,4) by auto
  hence img_insert: "range_vars (σ1(v := t)) = range_vars σ1  fv t"
    using subst_img_update by metis

  from Insert.prems(2) dom_insert have "subst_domain σ1  subst_domain θ2 = {}"
    by (auto simp add: subst_domain_def)
  moreover have "subst_domain σ1  range_vars θ2 = {}"
    using Insert.prems(3) dom_insert
    by (simp add: subst_domain_def)
  moreover have "range_vars σ1  subst_domain θ2 = {}"
    using Insert.prems(4) img_insert
    by blast
  ultimately have "wfsubst ?if" using Insert.IH[OF Insert.prems(1)] by metis
  
  have dom_union: "subst_domain ?if = subst_domain σ1  subst_domain θ2"
    by (auto simp add: subst_domain_def)
  hence "v  subst_domain ?if"
    using Insert.hyps(2) Insert.prems(2) dom_insert
    by (auto simp add: subst_domain_def)
  moreover have "v  range_vars ?if"
    using Insert.prems(3) Insert.hyps(3) dom_insert
    unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
  moreover have "fv t  insert v (subst_domain ?if) = {}"
    using Insert.hyps(4) Insert.prems(4) img_insert
    unfolding range_vars_alt_def by (fastforce simp add: subst_domain_def)
  ultimately show ?case
    using wfsubst_set.Insert ‹wfsubst ?if ?if_upd = ?if(v := t) wf_subst_properties
    by (metis (no_types, lifting))  
qed

lemma wf_subst_elim_append:
  assumes "wfsubst θ" "subst_elim θ v" "v  fv t"
  shows "subst_elim (θ(w := t)) v"
using assms
proof (induction θ rule: wfsubst_induct)
  case (Insert θ v' t')
  hence "q. v  fv (Var q  θ(v' := t'))" using subst_elimD by blast
  hence "q. v  fv (Var q  θ(v' := t', w := t))" using v  fv t by simp
  thus ?case by (metis subst_elimI' subst_apply_term.simps(1)) 
qed (simp add: subst_elim_def)

lemma wf_subst_elim_dom:
  assumes "wfsubst θ"
  shows "v  subst_domain θ. subst_elim θ v"
using assms
proof (induction θ rule: wfsubst_induct)
  case (Insert θ w t)
  have dom_insert: "subst_domain (θ(w := t))  insert w (subst_domain θ)"
    by (auto simp add: subst_domain_def)
  hence "v  subst_domain θ. subst_elim (θ(w := t)) v" using Insert.IH Insert.hyps(2,4)
    by (metis Insert.hyps(1) IntI disjoint_insert(2) empty_iff wf_subst_elim_append) 
  moreover have "w  fv t" using Insert.hyps(4) by simp
  hence "q. w  fv (Var q  θ(w := t))"
    by (metis fv_simps(1) fv_in_subst_img Insert.hyps(3) contra_subsetD 
              fun_upd_def singletonD subst_apply_term.simps(1)) 
  hence "subst_elim (θ(w := t)) w" by (metis subst_elimI')
  ultimately show ?case using dom_insert by blast
qed simp

lemma wf_subst_support_iff_mgt: "wfsubst θ  θ supports δ  θ  δ"
using subst_support_def subst_support_if_mgt_subst_idem wf_subst_subst_idem by blast 


subsection ‹Interpretations›
abbreviation interpretationsubst::"('a,'b) subst  bool" where
  "interpretationsubst θ  subst_domain θ = UNIV  ground (subst_range θ)"

lemma interpretation_substI:
  "(v. fv (θ v) = {})  interpretationsubst θ"
proof -
  assume "v. fv (θ v) = {}"
  moreover { fix v assume "fv (θ v) = {}" hence "v  subst_domain θ" by auto }
  ultimately show ?thesis by auto
qed

lemma interpretation_grounds[simp]:
  "interpretationsubst θ  fv (t  θ) = {}"
using subst_fv_dom_ground_if_ground_img[of t θ] by blast

lemma interpretation_grounds_all:
  "interpretationsubst θ  (v. fv (θ v) = {})"
by (metis range_vars_alt_def UNIV_I fv_in_subst_img subset_empty subst_dom_vars_in_subst)

lemma interpretation_grounds_all':
  "interpretationsubst θ  ground (M set θ)"
using subst_fv_dom_ground_if_ground_img[of _ θ]
by simp

lemma interpretation_comp:
  assumes "interpretationsubst θ" 
  shows "interpretationsubst (σ s θ)" "interpretationsubst (θ s σ)"
proof -
  have θ_fv: "fv (θ v) = {}" for v using interpretation_grounds_all[OF assms] by simp
  hence θ_fv': "fv (t  θ) = {}" for t
    by (metis all_not_in_conv subst_elimD subst_elimI' subst_apply_term.simps(1))

  from assms have "(σ s θ) v  Var v" for v
    unfolding subst_compose_def by (metis fv_simps(1) θ_fv' insert_not_empty)
  hence "subst_domain (σ s θ) = UNIV" by (simp add: subst_domain_def)
  moreover have "fv ((σ s θ) v) = {}" for v unfolding subst_compose_def using θ_fv' by simp
  hence "ground (subst_range (σ s θ))" by simp
  ultimately show "interpretationsubst (σ s θ)" ..

  from assms have "(θ s σ) v  Var v" for v
    unfolding subst_compose_def by (metis fv_simps(1) θ_fv insert_not_empty subst_to_var_is_var)
  hence "subst_domain (θ s σ) = UNIV" by (simp add: subst_domain_def)
  moreover have "fv ((θ s σ) v) = {}" for v
    unfolding subst_compose_def by (simp add: θ_fv trm_subst_ident) 
  hence "ground (subst_range (θ s σ))" by simp
  ultimately show "interpretationsubst (θ s σ)" ..
qed

lemma interpretation_subst_exists:
  "::('f,'v) subst. interpretationsubst "
proof -
  obtain c::"'f" where "c  UNIV" by simp
  then obtain ::"('f,'v) subst" where "v.  v = Fun c []" by simp
  hence "subst_domain  = UNIV" "ground (subst_range )"
    by (simp_all add: subst_domain_def)
  thus ?thesis by auto
qed

lemma interpretation_subst_exists':
  "θ::('f,'v) subst. subst_domain θ = X  ground (subst_range θ)"
proof -
  obtain ::"('f,'v) subst" where: "subst_domain  = UNIV" "ground (subst_range )"
    using interpretation_subst_exists by moura
  let  = "rm_vars (UNIV - X) "
  have 1: "subst_domain  = X" usingby (auto simp add: subst_domain_def)
  hence 2: "ground (subst_range )" usingby force
  show ?thesis using 1 2 by blast
qed

lemma interpretation_subst_idem:
  "interpretationsubst θ  subst_idem θ"
unfolding subst_idem_def
using interpretation_grounds_all[of θ] trm_subst_ident subst_eq_if_eq_vars
by fastforce

lemma subst_idem_comp_upd_eq:
  assumes "v  subst_domain " "subst_idem θ"
  shows " s θ = (v := θ v) s θ"
proof -
  from assms(1) have "( s θ) v = θ v" unfolding subst_compose_def by auto
  moreover have "w. w  v  ( s θ) w = ((v := θ v) s θ) w" unfolding subst_compose_def by auto
  moreover have "((v := θ v) s θ) v = θ v" using assms(2) unfolding subst_idem_def subst_compose_def
    by (metis fun_upd_same) 
  ultimately show ?thesis by (metis fun_upd_same fun_upd_triv subst_comp_upd1)
qed

lemma interpretation_dom_img_disjoint:
  "interpretationsubst   subst_domain   range_vars  = {}"
unfolding range_vars_alt_def by auto


subsection ‹Basic Properties of MGUs›
lemma MGU_is_mgu_singleton: "MGU θ t u = is_mgu θ {(t,u)}"
unfolding is_mgu_def unifiers_def by auto

lemma Unifier_in_unifiers_singleton: "Unifier θ s t  θ  unifiers {(s,t)}"
unfolding unifiers_def by auto

lemma subst_list_singleton_fv_subset:
  "(x  set (subst_list (subst v t) E). fv (fst x)  fv (snd x))
     fv t  (x  set E. fv (fst x)  fv (snd x))"
proof (induction E)
  case (Cons x E)
  let ?fvs = "λL. x  set L. fv (fst x)  fv (snd x)"
  let ?fvx = "fv (fst x)  fv (snd x)"
  let ?fvxsubst = "fv (fst x  Var(v := t))  fv (snd x  Var(v := t))"
  have "?fvs (subst_list (subst v t) (x#E)) = ?fvxsubst  ?fvs (subst_list (subst v t) E)"
    unfolding subst_list_def subst_def by auto
  hence "?fvs (subst_list (subst v t) (x#E))  ?fvxsubst  fv t  ?fvs E"
    using Cons.IH by blast
  moreover have "?fvs (x#E) = ?fvx  ?fvs E" by auto
  moreover have "?fvxsubst  ?fvx  fv t" using subst_fv_bound_singleton[of _ v t] by blast
  ultimately show ?case unfolding range_vars_alt_def by auto
qed (simp add: subst_list_def)

lemma subst_of_dom_subset: "subst_domain (subst_of L)  set (map fst L)"
proof (induction L rule: List.rev_induct)
  case (snoc x L)
  then obtain v t where x: "x = (v,t)" by (metis surj_pair)
  hence "subst_of (L@[x]) = Var(v := t) s subst_of L"
    unfolding subst_of_def subst_def by (induct L) auto
  hence "subst_domain (subst_of (L@[x]))  insert v (subst_domain (subst_of L))"
    using x subst_domain_compose[of "Var(v := t)" "subst_of L"]
    by (auto simp add: subst_domain_def)
  thus ?case using snoc.IH x by auto
qed simp

lemma wf_MGU_is_imgu_singleton: "wfMGU θ s t  is_imgu θ {(s,t)}"
proof -
  assume 1: "wfMGU θ s t"

  have 2: "subst_idem θ" by (metis wf_subst_subst_idem 1 wfMGU_def)

  have 3: "θ'  unifiers {(s,t)}. θ  θ'" "θ  unifiers {(s,t)}"
    by (metis 1 Unifier_in_unifiers_singleton wfMGU_def)+

  have "τ  unifiers {(s,t)}. τ = θ s τ" by (metis 2 3 subst_idem_def subst_compose_assoc)
  thus "is_imgu θ {(s,t)}" by (metis is_imgu_def θ  unifiers {(s,t)})
qed

lemma mgu_subst_range_vars:
  assumes "mgu s t = Some σ" shows "range_vars σ  vars_term s  vars_term t"
proof -
  obtain xs where *: "Unification.unify [(s, t)] [] = Some xs" and [simp]: "subst_of xs = σ"
    using assms by (simp split: option.splits)
  from unify_Some_UNIF [OF *] obtain ss
    where "compose ss = σ" and "UNIF ss {#(s, t)#} {#}" by auto
  with UNIF_range_vars_subset [of ss "{#(s, t)#}" "{#}"]
    show ?thesis by (metis vars_mset_singleton fst_conv snd_conv) 
qed

lemma mgu_subst_domain_range_vars_disjoint:
  assumes "mgu s t = Some σ" shows "subst_domain σ  range_vars σ = {}"
proof -
  have "is_imgu σ {(s, t)}" using assms mgu_sound by simp
  hence "σ = σ s σ" unfolding is_imgu_def by blast
  thus ?thesis by (metis subst_idemp_iff) 
qed

lemma mgu_same_empty: "mgu (t::('a,'b) term) t = Some Var"
proof -
  { fix E::"('a,'b) equation list" and U::"('b × ('a,'b) term) list"
    assume "(s,t)  set E. s = t"
    hence "Unification.unify E U = Some U"
    proof (induction E U rule: Unification.unify.induct)
      case (2 f S g T E U)
      hence *: "f = g" "S = T" by auto
      moreover have "(s,t)  set (zip T T). s = t" by (induct T) auto
      hence "(s,t)  set (zip T T@E). s = t" using "2.prems"(1) by auto
      moreover have "zip_option S T = Some (zip S T)" using S = T by auto
      hence **: "decompose (Fun f S) (Fun g T) = Some (zip S T)"
        using f = g unfolding decompose_def by auto
      ultimately have "Unification.unify (zip S T@E) U = Some U" using "2.IH" * by auto
      thus ?case using ** by auto
    qed auto
  }
  hence "Unification.unify [(t,t)] [] = Some []" by auto
  thus ?thesis by auto
qed

lemma mgu_var: assumes "x  fv t" shows "mgu (Var x) t = Some (Var(x := t))"
proof -
  have "unify [(Var x,t)] [] = Some [(x,t)]" using assms by (auto simp add: subst_list_def)
  moreover have "subst_of [(x,t)] = Var(x := t)" unfolding subst_of_def subst_def by simp
  ultimately show ?thesis by simp
qed

lemma mgu_gives_wellformed_subst:
  assumes "mgu s t = Some θ" shows "wfsubst θ"
using mgu_finite_subst_domain[OF assms] mgu_subst_domain_range_vars_disjoint[OF assms]
unfolding wfsubst_def
by auto

lemma mgu_gives_wellformed_MGU:
  assumes "mgu s t = Some θ" shows "wfMGU θ s t"
using mgu_subst_domain[OF assms] mgu_sound[OF assms] mgu_subst_range_vars [OF assms]
      MGU_is_mgu_singleton[of s θ t] is_imgu_imp_is_mgu[of θ "{(s,t)}"]
      mgu_gives_wellformed_subst[OF assms]
unfolding wfMGU_def by blast

lemma mgu_vars_bounded[dest?]:
  "mgu M N = Some σ  subst_domain σ  range_vars σ  fv M  fv N"
using mgu_gives_wellformed_MGU unfolding wfMGU_def by blast

lemma mgu_gives_subst_idem: "mgu s t = Some θ  subst_idem θ"
using mgu_sound[of s t θ] unfolding is_imgu_def subst_idem_def by auto

lemma mgu_always_unifies: "Unifier θ M N  δ. mgu M N = Some δ"
using mgu_complete Unifier_in_unifiers_singleton by blast

lemma mgu_gives_MGU: "mgu s t = Some θ  MGU θ s t"
using mgu_sound[of s t θ, THEN is_imgu_imp_is_mgu] MGU_is_mgu_singleton by metis

lemma mgu_eliminates[dest?]:
  assumes "mgu M N = Some σ"
  shows "(v  fv M  fv N. subst_elim σ v)  σ = Var"
  (is "?P M N σ")
proof (cases "σ = Var")
  case False
  then obtain v where v: "v  subst_domain σ" by auto
  hence "v  fv M  fv N" using mgu_vars_bounded[OF assms] by blast
  thus ?thesis using wf_subst_elim_dom[OF mgu_gives_wellformed_subst[OF assms]] v by blast
qed simp

lemma mgu_eliminates_dom:
  assumes "mgu x y = Some θ" "v  subst_domain θ"
  shows "subst_elim θ v"
using mgu_gives_wellformed_subst[OF assms(1)]
unfolding wfMGU_def wfsubst_def subst_elim_def
by (metis disjoint_iff_not_equal subst_dom_elim assms(2))

lemma unify_list_distinct:
  assumes "Unification.unify E B = Some U" "distinct (map fst B)"
  and "(x  set E. fv (fst x)  fv (snd x))  set (map fst B) = {}"
  shows "distinct (map fst U)"
using assms
proof (induction E B arbitrary: U rule: Unification.unify.induct)
  case 1 thus ?case by simp
next
  case (2 f X g Y E B U)
  let ?fvs = "λL. x  set L. fv (fst x)  fv (snd x)"
  from "2.prems"(1) obtain E' where *: "decompose (Fun f X) (Fun g Y) = Some E'"
    and [simp]: "f = g" "length X = length Y" "E' = zip X Y"
    and **: "Unification.unify (E'@E) B = Some U"
    by (auto split: option.splits)
  hence "t t'. (t,t')  set E'  fv t  fv (Fun f X)  fv t'  fv (Fun g Y)"
    by (metis zip_arg_subterm subtermeq_vars_subset)
  hence "?fvs E'  fv (Fun f X)  fv (Fun g Y)" by fastforce
  moreover have "fv (Fun f X)  set (map fst B) = {}" "fv (Fun g Y)  set (map fst B) = {}"
    using "2.prems"(3) by auto
  ultimately have "?fvs E'  set (map fst B) = {}" by blast
  moreover have "?fvs E  set (map fst B) = {}" using "2.prems"(3) by auto
  ultimately have "?fvs (E'@E)  set (map fst B) = {}" by auto
  thus ?case using "2.IH"[OF * ** "2.prems"(2)] by metis
next
  case (3 v t E B)
  let ?fvs = "λL. x  set L. fv (fst x)  fv (snd x)"
  let ?E' = "subst_list (subst v t) E"
  from "3.prems"(3) have "v  set (map fst B)" "fv t  set (map fst B) = {}" by force+
  hence *: "distinct (map fst ((v, t)#B))" using "3.prems"(2) by auto

  show ?case
  proof (cases "t = Var v")
    case True thus ?thesis using "3.prems" "3.IH"(1) by auto
  next
    case False
    hence "v  fv t" using "3.prems"(1) by auto
    hence "Unification.unify (subst_list (subst v t) E) ((v, t)#B) = Some U"
      using t  Var v "3.prems"(1) by auto
    moreover have "?fvs ?E'  set (map fst ((v, t)#B)) = {}"
    proof -
      have "v  ?fvs ?E'"
        unfolding subst_list_def subst_def
        by (simp add: v  fv t subst_remove_var)
      moreover have "?fvs ?E'  fv t  ?fvs E" by (metis subst_list_singleton_fv_subset)
      hence "?fvs ?E'  set (map fst B) = {}" using "3.prems"(3) by auto
      ultimately show ?thesis by auto
    qed 
    ultimately show ?thesis using "3.IH"(2)[OF t  Var v v  fv t _ *] by metis
  qed
next
  case (4 f X v E B U)
  let ?fvs = "λL. x  set L. fv (fst x)  fv (snd x)"
  let ?E' = "subst_list (subst v (Fun f X)) E"
  have *: "?fvs E  set (map fst B) = {}" using "4.prems"(3) by auto
  from "4.prems"(1) have "v  fv (Fun f X)" by force
  from "4.prems"(3) have **: "v  set (map fst B)" "fv (Fun f X)  set (map fst B) = {}" by force+
  hence ***: "distinct (map fst ((v, Fun f X)#B))" using "4.prems"(2) by auto
  from "4.prems"(3) have ****: "?fvs ?E'  set (map fst ((v, Fun f X)#B)) = {}"
  proof -
    have "v  ?fvs ?E'"
      unfolding subst_list_def subst_def
      using v  fv (Fun f X) subst_remove_var[of v "Fun f X"] by simp
    moreover have "?fvs ?E'  fv (Fun f X)  ?fvs E" by (metis subst_list_singleton_fv_subset)
    hence "?fvs ?E'  set (map fst B) = {}" using * ** by blast
    ultimately show ?thesis by auto
  qed
  have "Unification.unify (subst_list (subst v (Fun f X)) E) ((v, Fun f X) # B) = Some U"
    using v  fv (Fun f X) "4.prems"(1) by auto
  thus ?case using "4.IH"[OF v  fv (Fun f X) _ *** ****] by metis
qed

lemma mgu_None_is_subst_neq:
  fixes s t::"('a,'b) term" and δ::"('a,'b) subst"
  assumes "mgu s t = None"
  shows "s  δ  t  δ"
using assms mgu_always_unifies by force

lemma mgu_None_if_neq_ground:
  assumes "t  t'" "fv t = {}" "fv t' = {}"
  shows "mgu t t' = None"
proof (rule ccontr)
  assume "mgu t t'  None"
  then obtain δ where δ: "mgu t t' = Some δ" by auto
  hence "t  δ = t" "t'  δ = t'" using assms subst_ground_ident by auto
  thus False using assms(1) MGU_is_Unifier[OF mgu_gives_MGU[OF δ]] by auto
qed

lemma mgu_None_commutes:
  "mgu s t = None  mgu t s = None"
using mgu_complete[of s t]
      Unifier_in_unifiers_singleton[of s _ t]
      Unifier_sym[of t _ s]
      Unifier_in_unifiers_singleton[of t _ s]
      mgu_sound[of t s]
unfolding is_imgu_def
by fastforce

lemma mgu_img_subterm_subst:
  fixes δ::"('f,'v) subst" and s t u::"('f,'v) term"
  assumes "mgu s t = Some δ" "u  subtermsset (subst_range δ) - range Var"
  shows "u  ((subterms s  subterms t) - range Var) set δ"
proof -
  define subterms_tuples::"('f,'v) equation list  ('f,'v) terms" where subtt_def:
    "subterms_tuples  λE. subtermsset (fst ` set E)  subtermsset (snd ` set E)"
  define subterms_img::"('f,'v) subst  ('f,'v) terms" where subti_def:
    "subterms_img  λd. subtermsset (subst_range d)"

  define d where "d  λv t. subst v t::('f,'v) subst"
  define V where "V  range Var::('f,'v) terms"
  define R where "R  λd::('f,'v) subst. ((subterms s  subterms t) - V) set d"
  define M where "M  λE d. subterms_tuples E  subterms_img d"
  define Q where "Q  (λE d. M E d - V  R d - V)"
  define Q' where "Q'  (λE d d'. (M E d - V) set d'  (R d - V) set (d'::('f,'v) subst))"

  have Q_subst: "Q (subst_list (subst v t') E) (subst_of ((v, t')#B))" 
    when v_fv: "v  fv t'" and Q_assm: "Q ((Var v, t')#E) (subst_of B)"
    for v t' E B
  proof -
    define E' where "E'  subst_list (subst v t') E"
    define B' where "B'  subst_of ((v, t')#B)"

    have E': "E' = subst_list (d v t') E"
        and B': "B' = subst_of B s d v t'"
      using subst_of_simps(3)[of "(v, t')"]
      unfolding subst_def E'_def B'_def d_def by simp_all

    have vt_img_subt: "subtermsset (subst_range (d v t')) = subterms t'"
         and vt_dom: "subst_domain (d v t') = {v}"
      using v_fv by (auto simp add: subst_domain_def d_def subst_def)

    have *: "subterms u1  subtermsset (fst ` set E)" "subterms u2  subtermsset (snd ` set E)"
      when "(u1,u2)  set E" for u1 u2
      using that by auto

    have **: "subtermsset (d v t' ` (fv u  subst_domain (d v t')))  subterms t'"
      for u::"('f,'v) term"
      using vt_dom unfolding d_def by force

    have 1: "subterms_tuples E' - V  (subterms t' - V)  (subterms_tuples E - V set d v t')"
      (is "?A  ?B")
    proof
      fix u assume "u  ?A"
      then obtain u1 u2 where u12:
          "(u1,u2)  set E"
          "u  (subterms (u1  (d v t')) - V)  (subterms (u2  (d v t')) - V)"
        unfolding subtt_def subst_list_def E'_def d_def by moura
      hence "u  (subterms t' - V)  (((subterms_tuples E) set d v t') - V)"
        using subterms_subst[of u1 "d v t'"] subterms_subst[of u2 "d v t'"]
              *[OF u12(1)] **[of u1] **[of u2]
        unfolding subtt_def subst_list_def by auto
      moreover have
          "(subterms_tuples E set d v t') - V 
           (subterms_tuples E - V set d v t')  {t'}"
        unfolding subst_def subtt_def V_def d_def by force
      ultimately show "u  ?B" using u12 v_fv by auto
    qed

    have 2: "subterms_img B' - V 
             (subterms t' - V)  (subterms_img (subst_of B) - V set d v t')"
      using B' vt_img_subt subst_img_comp_subset'''[of "subst_of B" "d v t'"]
      unfolding subti_def subst_def V_def by argo

    have 3: "subterms_tuples ((Var v, t')#E) - V = (subterms t' - V)  (subterms_tuples E - V)"
      by (auto simp add: subst_def subtt_def V_def)

    have "fvset (subterms t' - V)  subst_domain (d v t') = {}"
      using v_fv vt_dom fv_subterms[of t'] by fastforce
    hence 4: "subterms t' - V set d v t' = subterms t' - V"
      using set_subst_ident[of "subterms t' - range Var" "d v t'"] by (simp add: V_def)

    have "M E' B' - V  M ((Var v, t')#E) (subst_of B) - V set d v t'"
      using 1 2 3 4 unfolding M_def by blast
    moreover have "Q' ((Var v, t')#E) (subst_of B) (d v t')"
      using Q_assm unfolding Q_def Q'_def by auto
    moreover have "R (subst_of B) set d v t' = R (subst_of ((v,t')#B))"
      unfolding R_def d_def by auto 
    ultimately have
      "M (subst_list (d v t') E) (subst_of ((v, t')#B)) - V  R (subst_of ((v, t')#B)) - V"
      unfolding Q'_def E'_def B'_def d_def by blast
    thus ?thesis unfolding Q_def M_def R_def d_def by blast
  qed

  have "u  subterms s  subterms t - V set subst_of U"
    when assms':
      "unify E B = Some U"
      "u  subtermsset (subst_range (subst_of U)) - V"
      "Q E (subst_of B)"
    for E B U and T::"('f,'v) term list"
    using assms'
  proof (induction E B arbitrary: U rule: Unification.unify.induct)
    case (1 B) thus ?case by (auto simp add: Q_def M_def R_def subti_def)
  next
    case (2 g X h Y E B U)
    from "2.prems"(1) obtain E' where E':
        "decompose (Fun g X) (Fun h Y) = Some E'"
        "g = h" "length X = length Y" "E' = zip X Y"
        "Unification.unify (E'@E) B = Some U"
      by (auto split: option.splits)
    moreover have "subterms_tuples (E'@E)  subterms_tuples ((Fun g X, Fun h Y)#E)"
    proof
      fix u assume "u  subterms_tuples (E'@E)"
      then obtain u1 u2 where u12: "(u1,u2)  set (E'@E)" "u  subterms u1  subterms u2"
        unfolding subtt_def by fastforce
      thus "u  subterms_tuples ((Fun g X, Fun h Y)#E)"
      proof (cases "(u1,u2)  set E'")
        case True
        hence "subterms u1  subterms (Fun g X)" "subterms u2  subterms (Fun h Y)"
          using E'(4) subterms_subset params_subterms subsetCE
          by (metis set_zip_leftD, metis set_zip_rightD)
        thus ?thesis using u12 unfolding subtt_def by auto
      next
        case False thus ?thesis using u12 unfolding subtt_def by fastforce
      qed
     qed
    hence "Q (E'@E) (subst_of B)" using "2.prems"(3) unfolding Q_def M_def by blast
    ultimately show ?case using "2.IH"[of E' U] "2.prems" by meson
  next
    case (3 v t' E B)
    show ?case
    proof (cases "t' = Var v")
      case True thus ?thesis
        using "3.prems" "3.IH"(1) unfolding Q_def M_def V_def subtt_def by auto
    next
      case False
      hence 1: "v  fv t'" using "3.prems"(1) by auto
      hence "unify (subst_list (subst v t') E) ((v, t')#B) = Some U"
        using False "3.prems"(1) by auto
      thus ?thesis
        using Q_subst[OF 1 "3.prems"(3)]
              "3.IH"(2)[OF False 1 _ "3.prems"(2)]
        by metis
    qed
  next
    case (4 g X v E B U)
    have 1: "v  fv (Fun g X)" using "4.prems"(1) not_None_eq by fastforce
    hence 2: "unify (subst_list (subst v (Fun g X)) E) ((v, Fun g X)#B) = Some U"
      using "4.prems"(1) by auto

    have 3: "Q ((Var v, Fun g X)#E) (subst_of B)"
      using "4.prems"(3) unfolding Q_def M_def subtt_def by auto
    
    show ?case
      using Q_subst[OF 1 3] "4.IH"[OF 1 2 "4.prems"(2)]
      by metis
  qed
  moreover obtain D where "unify [(s, t)] [] = Some D" "δ = subst_of D"
    using assms(1) by (auto split: option.splits)
  moreover have "Q [(s,t)] (subst_of [])"
    unfolding Q_def M_def R_def subtt_def subti_def
    by force
  ultimately show ?thesis using assms(2) unfolding V_def by auto
qed

lemma mgu_img_consts:
  fixes δ::"('f,'v) subst" and s t::"('f,'v) term" and c::'f and z::'v
  assumes "mgu s t = Some δ" "Fun c []  subtermsset (subst_range δ)"
  shows "Fun c []  subterms s  subterms t"
proof -
  obtain u where "u  (subterms s  subterms t) - range Var" "u  δ = Fun c []"
    using mgu_img_subterm_subst[OF assms(1), of "Fun c []"] assms(2) by force
  thus ?thesis by (cases u) auto
qed

lemma mgu_img_consts':
  fixes δ::"('f,'v) subst" and s t::"('f,'v) term" and c::'f and z::'v
  assumes "mgu s t = Some δ" "δ z = Fun c []"
  shows "Fun c []  s  Fun c []  t"
using mgu_img_consts[OF assms(1)] assms(2)
by (metis Un_iff in_subterms_Union subst_imgI term.distinct(1)) 

lemma mgu_img_composed_var_term:
  fixes δ::"('f,'v) subst" and s t::"('f,'v) term" and f::'f and Z::"'v list"
  assumes "mgu s t = Some δ" "Fun f (map Var Z)  subtermsset (subst_range δ)"
  shows "Z'. map δ Z' = map Var Z  Fun f (map Var Z')  subterms s  subterms t"
proof -
  obtain u where u: "u  (subterms s  subterms t) - range Var" "u  δ = Fun f (map Var Z)"
    using mgu_img_subterm_subst[OF assms(1), of "Fun f (map Var Z)"] assms(2) by fastforce
  then obtain T where T: "u = Fun f T" "map (λt. t  δ) T = map Var Z" by (cases u) auto
  have "t  set T. x. t = Var x" using T(2) by (induct T arbitrary: Z) auto
  then obtain Z' where Z': "map Var Z' = T" by (metis ex_map_conv) 
  hence "map δ Z' = map Var Z" using T(2) by (induct Z' arbitrary: T Z) auto
  thus ?thesis using u(1) T(1) Z' by auto
qed


subsection ‹Lemmata: The "Inequality Lemmata"›
text ‹Subterm injectivity (a stronger injectivity property)›
definition subterm_inj_on where
  "subterm_inj_on f A  xA. yA. (v. v  f x  v  f y)  x = y"

lemma subterm_inj_on_imp_inj_on: "subterm_inj_on f A  inj_on f A"
unfolding subterm_inj_on_def inj_on_def by fastforce

lemma subst_inj_on_is_bij_betw:
  "inj_on θ (subst_domain θ) = bij_betw θ (subst_domain θ) (subst_range θ)"
unfolding inj_on_def bij_betw_def by auto

lemma subterm_inj_on_alt_def:
    "subterm_inj_on f A 
     (inj_on f A  (s  f`A. u  f`A. (v. v  s  v  u)  s = u))"
    (is "?A  ?B")
unfolding subterm_inj_on_def inj_on_def by fastforce

lemma subterm_inj_on_alt_def':
    "subterm_inj_on θ (subst_domain θ) 
     (inj_on θ (subst_domain θ) 
      (s  subst_range θ. u  subst_range θ. (v. v  s  v  u)  s = u))"
    (is "?A  ?B")
by (metis subterm_inj_on_alt_def subst_range.simps)

lemma subterm_inj_on_subset:
  assumes "subterm_inj_on f A"
    and "B  A"
  shows "subterm_inj_on f B"
proof -
  have "inj_on f A" "sf ` A. uf ` A. (v. v  s  v  u)  s = u"
    using subterm_inj_on_alt_def[of f A] assms(1) by auto
  moreover have "f ` B  f ` A" using assms(2) by auto
  ultimately have "inj_on f B" "sf ` B. uf ` B. (v. v  s  v  u)  s = u"
    using inj_on_subset[of f A] assms(2) by blast+
  thus ?thesis by (metis subterm_inj_on_alt_def)
qed

lemma inj_subst_unif_consts:
  fixes  θ σ::"('f,'v) subst" and s t::"('f,'v) term"
  assumes θ: "subterm_inj_on θ (subst_domain θ)" "x  (fv s  fv t) - X. c. θ x = Fun c []"
             "subtermsset (subst_range θ)  (subterms s  subterms t) = {}" "ground (subst_range θ)"
             "subst_domain θ  X = {}"
  and: "ground (subst_range )" "subst_domain  = subst_domain θ"
  and unif: "Unifier σ (s  θ) (t  θ)"
  shows "δ. Unifier δ (s  ) (t  )"
proof -
  let ?xs = "subst_domain θ"
  let ?ys = "(fv s  fv t) - ?xs"

  have "δ::('f,'v) subst. s  δ = t  δ" by (metis subst_subst_compose unif)
  then obtain δ::"('f,'v) subst" where δ: "mgu s t = Some δ"
    using mgu_always_unifies by moura
  have 1: "σ::('f,'v) subst. s  θ  σ = t  θ  σ" by (metis unif)
  have 2: "γ::('f,'v) subst. s  θ  γ = t  θ  γ  δ  θ s γ" using mgu_gives_MGU[OF δ] by simp
  have 3: "(z::'v) (c::'f). δ z = Fun c []  Fun c []  s  Fun c []  t"
    by (rule mgu_img_consts'[OF δ])
  have 4: "subst_domain δ  range_vars δ = {}"
    by (metis mgu_gives_wellformed_subst[OF δ] wfsubst_def)
  have 5: "subst_domain δ  range_vars δ  fv s  fv t"
    by (metis mgu_gives_wellformed_MGU[OF δ] wfMGU_def)

  { fix x and γ::"('f,'v) subst" assume "x  subst_domain θ"
    hence "(θ s γ) x = θ x"
      using θ(4) ident_comp_subst_trm_if_disj[of γ θ]
      unfolding range_vars_alt_def by fast
  }
  then obtain τ::"('f,'v) subst" where τ: "x  subst_domain θ. θ x = (δ s τ) x" using 1 2 by moura

  have *: "x. x  subst_domain δ  subst_domain θ  y  ?ys. δ x = Var y"
  proof -
    fix x assume "x  subst_domain δ  ?xs"
    hence x: "x  subst_domain δ" "x  subst_domain θ" by auto
    then obtain c where c: "θ x = Fun c []" using θ(2,5) 5 by moura
    hence *: "(δ s τ) x = Fun c []" using τ x by fastforce
    hence **: "x  subst_domain (δ s τ)" "Fun c []  subst_range (δ s τ)"
      by (auto simp add: subst_domain_def)
    have "δ x = Fun c []  (z. δ x = Var z  τ z = Fun c [])"
      by (rule subst_img_comp_subset_const'[OF *])
    moreover have "δ x  Fun c []"
    proof (rule ccontr)
      assume "¬δ x  Fun c []"
      hence "Fun c []  s  Fun c []  t" using 3 by metis
      moreover have "u  subst_range θ. u  subterms s  subterms t"
        using θ(3) by force
      hence "Fun c []  subterms s  subterms t"
        by (metis c ‹ground (subst_range θ)x(2) ground_subst_dom_iff_img) 
      ultimately show False by auto
    qed
    moreover have "x'  subst_domain θ. δ x  Var x'"
    proof (rule ccontr)
      assume "¬(x'  subst_domain θ. δ x  Var x')"
      then obtain x' where x': "x'  subst_domain θ" "δ x = Var x'" by moura
      hence "τ x' = Fun c []" "(δ s τ) x = Fun c []" using * unfolding subst_compose_def by auto
      moreover have "x  x'"
        using x(1) x'(2) 4
        by (auto simp add: subst_domain_def)
      moreover have "x'  subst_domain δ"
        using x'(2) mgu_eliminates_dom[OF δ]
        by (metis (no_types) subst_elim_def subst_apply_term.simps(1) vars_iff_subterm_or_eq)
      moreover have "(δ s τ) x = θ x" "(δ s τ) x' = θ x'" using τ x(2) x'(1) by auto
      ultimately show False
        using subterm_inj_on_imp_inj_on[OF θ(1)] *
        by (simp add: inj_on_def subst_compose_def x'(2) subst_domain_def)
    qed
    ultimately show "y  ?ys. δ x = Var y"
      by (metis 5 x(2) subtermeqI' vars_iff_subtermeq DiffI Un_iff subst_fv_imgI sup.orderE)
  qed

  have **: "inj_on δ (subst_domain δ  ?xs)"
  proof (intro inj_onI)
    fix x y assume *:
      "x  subst_domain δ  subst_domain θ" "y  subst_domain δ  subst_domain θ" "δ x = δ y"
    hence "(δ s τ) x = (δ s τ) y" unfolding subst_compose_def by auto
    hence "θ x = θ y" using τ * by auto
    thus "x = y" using inj_onD[OF subterm_inj_on_imp_inj_on[OF θ(1)]] *(1,2) by simp
  qed

  define α where "α = (λy'. if Var y'  δ ` (subst_domain δ  ?xs)
                            then Var ((inv_into (subst_domain δ  ?xs) δ) (Var y'))
                            else Var y'::('f,'v) term)"
  have a1: "Unifier (δ s α) s t" using mgu_gives_MGU[OF δ] by auto

  define δ' where "δ' = δ s α"
  have d1: "subst_domain δ'  ?ys"
  proof
    fix z assume z: "z  subst_domain δ'"
    have "z  ?xs  z  subst_domain δ'"
    proof (cases "z  subst_domain δ")
      case True
      moreover assume "z  ?xs"
      ultimately have z_in: "z  subst_domain δ  ?xs" by simp
      then obtain y where y: "δ z = Var y" "y  ?ys" using * by moura
      hence "α y = Var ((inv_into (subst_domain δ  ?xs) δ) (Var y))"
        using α_def z_in by simp
      hence "α y = Var z" by (metis y(1) z_in ** inv_into_f_eq)
      hence "δ' z = Var z" using δ'_def y(1) subst_compose_def[of δ α] by simp
      thus ?thesis by (simp add: subst_domain_def)
    next
      case False
      hence "δ z = Var z" by (simp add: subst_domain_def)
      moreover assume "z  ?xs"
      hence "α z = Var z" using α_def * by force
      ultimately show ?thesis
        using δ'_def subst_compose_def[of δ α]
        by (simp add: subst_domain_def)
    qed
    moreover have "subst_domain α  range_vars δ"
      unfolding δ'_def α_def range_vars_alt_def
      by (auto simp add: subst_domain_def)
    hence "subst_domain δ'  subst_domain δ  range_vars δ"
      using subst_domain_compose[of δ α] unfolding δ'_def by blast
    ultimately show "z  ?ys" using 5 z by auto
  qed
  have d2: "Unifier (δ' s ) s t" using a1 δ'_def by auto
  have d3: " s δ' s  = δ' s "
  proof -
    { fix z::'v assume z: "z  ?xs"
      then obtain u where u: " z = u" "fv u = {}" usingby auto
      hence "( s δ' s ) z = u" by (simp add: subst_compose subst_ground_ident)
      moreover have "z  subst_domain δ'" using d1 z by auto
      hence "δ' z = Var z" by (simp add: subst_domain_def)
      hence "(δ' s ) z = u" using u(1) by (simp add: subst_compose)
      ultimately have "( s δ' s ) z = (δ' s ) z" by metis
    } moreover {
      fix z::'v assume "z  ?ys"
      hence "z  subst_domain " using(2) by auto
      hence "( s δ' s ) z = (δ' s ) z" by (simp add: subst_compose subst_domain_def)
    } moreover {
      fix z::'v assume "z  ?xs" "z  ?ys"
      hence " z = Var z" "δ' z = Var z" using(2) d1 by blast+
      hence "( s δ' s ) z = (δ' s ) z" by (simp add: subst_compose)
    } ultimately show ?thesis by auto
  qed

  from d2 d3 have "Unifier (δ' s ) (s  ) (t  )" by (metis subst_subst_compose) 
  thus ?thesis by metis
qed

lemma inj_subst_unif_comp_terms:
  fixes  θ σ::"('f,'v) subst" and s t::"('f,'v) term"
  assumes θ: "subterm_inj_on θ (subst_domain θ)" "ground (subst_range θ)"
             "subtermsset (subst_range θ)  (subterms s  subterms t) = {}"
             "(fv s  fv t) - subst_domain θ  X"
  and tfr: "f U. Fun f U  subterms s  subterms t  U = []  (u  set U. u  Var ` X)"
  and: "ground (subst_range )" "subst_domain  = subst_domain θ"
  and unif: "Unifier σ (s  θ) (t  θ)"
  shows "δ. Unifier δ (s  ) (t  )"
proof -
  let ?xs = "subst_domain θ"
  let ?ys = "(fv s  fv t) - ?xs"

  have "ground (subst_range θ)" using θ(2) by auto

  have "δ::('f,'v) subst. s  δ = t  δ" by (metis subst_subst_compose unif)
  then obtain δ::"('f,'v) subst" where δ: "mgu s t = Some δ"
    using mgu_always_unifies by moura
  have 1: "σ::('f,'v) subst. s  θ  σ = t  θ  σ" by (metis unif)
  have 2: "γ::('f,'v) subst. s  θ  γ = t  θ  γ  δ  θ s γ" using mgu_gives_MGU[OF δ] by simp
  have 3: "(z::'v) (c::'f).  Fun c []  δ z  Fun c []  s  Fun c []  t"
    using mgu_img_consts[OF δ] by force
  have 4: "subst_domain δ  range_vars δ = {}"
    using mgu_gives_wellformed_subst[OF δ]
    by (metis wfsubst_def)
  have 5: "subst_domain δ  range_vars δ  fv s  fv t"
    using mgu_gives_wellformed_MGU[OF δ]
    by (metis wfMGU_def)

  { fix x and γ::"('f,'v) subst" assume "x  subst_domain θ"
    hence "(θ s γ) x = θ x"
      using ‹ground (subst_range θ) ident_comp_subst_trm_if_disj[of γ θ x]
      unfolding range_vars_alt_def by blast
  }
  then obtain τ::"('f,'v) subst" where τ: "x  subst_domain θ. θ x = (δ s τ) x" using 1 2 by moura

  have ***: "x. x  subst_domain δ  subst_domain θ  fv (δ x)  ?ys"
  proof -
    fix x assume "x  subst_domain δ  ?xs"
    hence x: "x  subst_domain δ" "x  subst_domain θ" by auto
    moreover have "¬(x'  ?xs. x'  fv (δ x))"
    proof (rule ccontr)
      assume "¬¬(x'  ?xs. x'  fv (δ x))"
      then obtain x' where x': "x'  fv (δ x)" "x'  ?xs" by metis
      have "x  x'" "x'  subst_domain δ" "δ x' = Var x'"
        using 4 x(1) x'(1) unfolding range_vars_alt_def by auto
      hence "(δ s τ) x'  (δ s τ) x" "τ x' = (δ s τ) x'"
        using τ x(2) x'(2)
        by (metis subst_compose subst_mono vars_iff_subtermeq x'(1),
            metis subst_apply_term.simps(1) subst_compose_def)
      hence "θ x'  θ x" using τ x(2) x'(2) by auto
      thus False
        using θ(1) x'(2) x(2) x  x'
        unfolding subterm_inj_on_def 
        by (meson subtermeqI') 
    qed
    ultimately show "fv (δ x)  ?ys"
      using 5 subst_dom_vars_in_subst[of x δ] subst_fv_imgI[of δ x]
      by blast
  qed

  have **: "inj_on δ (subst_domain δ  ?xs)"
  proof (intro inj_onI)
    fix x y assume *:
      "x  subst_domain δ  subst_domain θ" "y  subst_domain δ  subst_domain θ" "δ x = δ y"
    hence "(δ s τ) x = (δ s τ) y" unfolding subst_compose_def by auto
    hence "θ x = θ y" using τ * by auto
    thus "x = y" using inj_onD[OF subterm_inj_on_imp_inj_on[OF θ(1)]] *(1,2) by simp
  qed

  have *: "x. x  subst_domain δ  subst_domain θ  y  ?ys. δ x = Var y"
  proof (rule ccontr)
    fix xi assume xi_assms: "xi  subst_domain δ  subst_domain θ" "¬(y  ?ys. δ xi = Var y)"
    hence xi_θ: "xi  subst_domain θ" and δ_xi_comp: "¬(y. δ xi = Var y)"
      using ***[of xi] 5 by auto
    then obtain f T where f: "δ xi = Fun f T" by (cases "δ xi") moura

    have "g Y'. Y'  []  Fun g (map Var Y')  δ xi  set Y'  ?ys"
    proof -
      have "c. Fun c []  δ xi  Fun c []  θ xi"
        using τ xi_θ by (metis const_subterm_subst subst_compose)
      hence 1: "c. ¬(Fun c []  δ xi)"
        using 3[of _ xi] xi_θ θ(3)
        by auto
      
      have "¬(x. δ xi = Var x)" using f by auto
      hence "g S. Fun g S  δ xi  (s  set S. (c. s = Fun c [])  (x. s = Var x))"
        using nonvar_term_has_composed_shallow_term[of "δ xi"] by auto
      then obtain g S where gS: "Fun g S  δ xi" "s  set S. (c. s = Fun c [])  (x. s = Var x)"
        by moura

      have "s  set S. x. s = Var x"
        using 1 term.order_trans gS
        by (metis (no_types, lifting) UN_I term.order_refl subsetCE subterms.simps(2) sup_ge2)
      then obtain S' where 2: "map Var S' = S" by (metis ex_map_conv)

      have "S  []" using 1 term.order_trans[OF _ gS(1)] by fastforce
      hence 3: "S'  []" "Fun g (map Var S')  δ xi" using gS(1) 2 by auto

      have "set S'  fv (Fun g (map Var S'))" by simp
      hence 4: "set S'  fv (δ xi)" using 3(2) fv_subterms by force
      
      show ?thesis using ***[OF xi_assms(1)] 2 3 4 by auto
    qed
    then obtain g Y' where g: "Y'  []" "Fun g (map Var Y')  δ xi" "set Y'  ?ys" by moura
    then obtain X where X: "map δ X = map Var Y'" "Fun g (map Var X)  subterms s  subterms t"
      using mgu_img_composed_var_term[OF δ, of g Y'] by force
    hence "(u::('f,'v) term)  set (map Var X). u  Var ` ?ys"
      using θ(4) tfr g(1) by fastforce
    then obtain j where j: "j < length X" "X ! j  ?ys"
      by (metis image_iff[of _ Var "fv s  fv t - subst_domain θ"] nth_map[of _ X Var]
                in_set_conv_nth[of _ "map Var X"] length_map[of Var X])

    define yj' where yj': "yj'  Y' ! j"
    define xj where xj: "xj  X ! j"

    have "xj  fv s  fv t"
      using j X(1) g(3) 5 xj yj'
      by (metis length_map nth_map term.simps(1) in_set_conv_nth le_supE subsetCE subst_domI) 
    hence xj_θ: "xj  subst_domain θ" using j unfolding xj by simp

    have len: "length X = length Y'" by (rule map_eq_imp_length_eq[OF X(1)])
    
    have "Var yj'  δ xi"
      using term.order_trans[OF _ g(2)] j(1) len unfolding yj' by auto
    hence "τ yj'  θ xi"
      using τ xi_θ by (metis subst_apply_term.simps(1) subst_compose_def subst_mono) 
    moreover have δ_xj_var: "Var yj' = δ xj"
      using X(1) len j(1) nth_map
      unfolding xj yj' by metis
    hence "τ yj' = θ xj" using τ xj_θ by (metis subst_apply_term.simps(1) subst_compose_def) 
    moreover have "xi  xj" using δ_xi_comp δ_xj_var by auto
    ultimately show False using θ(1) xi_θ xj_θ unfolding subterm_inj_on_def by blast
  qed

  define α where "α = (λy'. if Var y'  δ ` (subst_domain δ  ?xs)
                            then Var ((inv_into (subst_domain δ  ?xs) δ) (Var y'))
                            else Var y'::('f,'v) term)"
  have a1: "Unifier (δ s α) s t" using mgu_gives_MGU[OF δ] by auto

  define δ' where "δ' = δ s α"
  have d1: "subst_domain δ'  ?ys"
  proof
    fix z assume z: "z  subst_domain δ'"
    have "z  ?xs  z  subst_domain δ'"
    proof (cases "z  subst_domain δ")
      case True
      moreover assume "z  ?xs"
      ultimately have z_in: "z  subst_domain δ  ?xs" by simp
      then obtain y where y: "δ z = Var y" "y  ?ys" using * by moura
      hence "α y = Var ((inv_into (subst_domain δ  ?xs) δ) (Var y))"
        using α_def z_in by simp
      hence "α y = Var z" by (metis y(1) z_in ** inv_into_f_eq)
      hence "δ' z = Var z" using δ'_def y(1) subst_compose_def[of δ α] by simp
      thus ?thesis by (simp add: subst_domain_def)
    next
      case False
      hence "δ z = Var z" by (simp add: subst_domain_def)
      moreover assume "z  ?xs"
      hence "α z = Var z" using α_def * by force
      ultimately show ?thesis using δ'_def subst_compose_def[of δ α] by (simp add: subst_domain_def)
    qed
    moreover have "subst_domain α  range_vars δ"
      unfolding δ'_def α_def range_vars_alt_def subst_domain_def
      by auto
    hence "subst_domain δ'  subst_domain δ  range_vars δ"
      using subst_domain_compose[of δ α]
      unfolding δ'_def by blast
    ultimately show "z  ?ys" using 5 z by blast
  qed
  have d2: "Unifier (δ' s ) s t" using a1 δ'_def by auto
  have d3: " s δ' s  = δ' s "
  proof -
    { fix z::'v assume z: "z  ?xs"
      then obtain u where u: " z = u" "fv u = {}" usingby auto
      hence "( s δ' s ) z = u" by (simp add: subst_compose subst_ground_ident)
      moreover have "z  subst_domain δ'" using d1 z by auto
      hence "δ' z = Var z" by (simp add: subst_domain_def)
      hence "(δ' s ) z = u" using u(1) by (simp add: subst_compose)
      ultimately have "( s δ' s ) z = (δ' s ) z" by metis
    } moreover {
      fix z::'v assume "z  ?ys"
      hence "z  subst_domain " using(2) by auto
      hence "( s δ' s ) z = (δ' s ) z" by (simp add: subst_compose subst_domain_def)
    } moreover {
      fix z::'v assume "z  ?xs" "z  ?ys"
      hence " z = Var z" "δ' z = Var z" using(2) d1 by blast+
      hence "( s δ' s ) z = (δ' s ) z" by (simp add: subst_compose)
    } ultimately show ?thesis by auto
  qed

  from d2 d3 have "Unifier (δ' s ) (s  ) (t  )" by (metis subst_subst_compose) 
  thus ?thesis by metis
qed

context
begin
private lemma sat_ineq_subterm_inj_subst_aux:
  fixes ::"('f,'v) subst"
  assumes "Unifier σ (s  ) (t  )" "ground (subst_range )"
          "(fv s  fv t) - X  subst_domain " "subst_domain   X = {}"
  shows "δ::('f,'v) subst. subst_domain δ = X  ground (subst_range δ)  s  δ   = t  δ  "
proof -
  have "σ. Unifier σ (s  ) (t  )  interpretationsubst σ"
  proof -
    obtain ℐ'::"('f,'v) subst" where *: "interpretationsubst ℐ'"
      using interpretation_subst_exists by metis
    hence "Unifier (σ s ℐ') (s  ) (t  )" using assms(1) by simp
    thus ?thesis using * interpretation_comp by blast
  qed
  then obtain σ' where σ': "Unifier σ' (s  ) (t  )" "interpretationsubst σ'" by moura
  
  define σ'' where "σ'' = rm_vars (UNIV - X) σ'"
  
  have *: "fv (s  )  X" "fv (t  )  X"
    using assms(2,3) subst_fv_unfold_ground_img[of ]
    unfolding range_vars_alt_def
    by (simp_all add: Diff_subset_conv Un_commute)
  hence **: "subst_domain σ'' = X" "ground (subst_range σ'')"
    using rm_vars_img_subset[of "UNIV - X" σ'] rm_vars_dom[of "UNIV - X" σ'] σ'(2)
    unfolding σ''_def by auto
  hence "t. t    σ'' = t  σ''  "
    using subst_eq_if_disjoint_vars_ground[OF _ _ assms(2)] assms(4) by blast
  moreover have "Unifier σ'' (s  ) (t  )"
    using Unifier_dom_restrict[OF σ'(1)] σ''_def * by blast
  ultimately show ?thesis using ** by auto
qed

text ‹
  The "inequality lemma": This lemma gives sufficient syntactic conditions for finding substitutions
  θ› under which terms s› and t› are not unifiable.

  This is useful later when establishing the typing results since we there want to find well-typed
  solutions to inequality constraints / "negative checks" constraints, and this lemma gives
  conditions for protocols under which such constraints are well-typed satisfiable if satisfiable.
›
lemma sat_ineq_subterm_inj_subst:
  fixes θ  δ::"('f,'v) subst"
  assumes θ: "subterm_inj_on θ (subst_domain θ)"
             "ground (subst_range θ)"
             "subst_domain θ  X = {}"
             "subtermsset (subst_range θ)  (subterms s  subterms t) = {}"
             "(fv s  fv t) - subst_domain θ  X"
  and tfr: "(x  (fv s  fv t) - X. c. θ x = Fun c []) 
            (f U. Fun f U  subterms s  subterms t  U = []  (u  set U. u  Var ` X))"
  and: "δ::('f,'v) subst. subst_domain δ = X  ground (subst_range δ)  s  δ    t  δ  "
         "(fv s  fv t) - X  subst_domain " "subst_domain   X = {}" "ground (subst_range )"
         "subst_domain  = subst_domain θ"
  and δ: "subst_domain δ = X" "ground (subst_range δ)"
  shows "s  δ  θ  t  δ  θ"
proof -
  have "σ. ¬Unifier σ (s  ) (t  )"
    by (metis(1) sat_ineq_subterm_inj_subst_aux[OF _ ℐ(4,2,3)])
  hence "¬Unifier δ (s  θ) (t  θ)"
    using inj_subst_unif_consts[OF θ(1) _ θ(4,2,3)(4,5)]
          inj_subst_unif_comp_terms[OF θ(1,2,4,5) _ ℐ(4,5)]
          tfr
    by metis
  moreover have "subst_domain δ  subst_domain θ = {}" using θ(2,3) δ(1) by auto
  ultimately show ?thesis using δ subst_eq_if_disjoint_vars_ground[OF _ θ(2) δ(2)] by metis
qed
end

lemma ineq_subterm_inj_cond_subst:
  assumes "X  range_vars θ = {}"
  and "f T. Fun f T  subtermsset S  T = []  (u  set T. u  Var`X)"
  shows "f T. Fun f T  subtermsset (S set θ)  T = []  (u  set T. u  Var`X)"
proof (intro allI impI)
  let ?M = "λS. subtermsset S set θ"
  let ?N = "λS. subtermsset (θ ` (fvset S  subst_domain θ))"

  fix f T assume "Fun f T  subtermsset (S set θ)"
  hence 1: "Fun f T  ?M S  Fun f T  ?N S"
    using subterms_subst[of _ θ] by auto

  have 2: "Fun f T  subtermsset (subst_range θ)  u  set T. u  Var`X"
    using fv_subset_subterms[of "Fun f T" "subst_range θ"] assms(1)
    unfolding range_vars_alt_def by force

  have 3: "x  subst_domain θ. θ x  Var`X"
  proof
    fix x assume "x  subst_domain θ"
    hence "fv (θ x)  range_vars θ"
      using subst_dom_vars_in_subst subst_fv_imgI
      unfolding range_vars_alt_def by auto
    thus "θ x  Var`X" using assms(1) by auto
  qed

  show "T = []  (s  set T. s  Var`X)" using 1
  proof
    assume "Fun f T  ?M S"
    then obtain u where u: "u  subtermsset S" "u  θ = Fun f T" by fastforce
    show ?thesis
    proof (cases u)
      case (Var x)
      hence "Fun f T  subst_range θ" using u(2) by (simp add: subst_domain_def)
      hence "u  set T. u  Var`X" using 2 by force
      thus ?thesis by auto
    next
      case (Fun g S)
      hence "S = []  (u  set S. u  Var`X)" using assms(2) u(1) by metis
      thus ?thesis
      proof
        assume "S = []" thus ?thesis using u(2) Fun by simp
      next
        assume "u  set S. u  Var`X"
        then obtain u' where u': "u'  set S" "u'  Var`X" by moura
        hence "u'  θ  set T" using u(2) Fun by auto
        thus ?thesis using u'(2) 3 by (cases u') force+
      qed
    qed
  next
    assume "Fun f T  ?N S"
    thus ?thesis using 2 by force
  qed
qed


subsection ‹Lemmata: Sufficient Conditions for Term Matching›
text ‹Injective substitutions from variables to variables are invertible›
definition subst_var_inv where
  "subst_var_inv δ X  (λx. if Var x  δ ` X then Var ((inv_into X δ) (Var x)) else Var x)"

lemma inj_var_ran_subst_is_invertible:
  assumes δ_inj_on_t: "inj_on δ (fv t)"
    and δ_var_on_t: "δ ` fv t  range Var"
  shows "t = t  δ s subst_var_inv δ (fv t)"
proof -
  have "δ x  subst_var_inv δ (fv t) = Var x" when x: "x  fv t" for x
  proof -
    obtain y where y: "δ x = Var y" using x δ_var_on_t by auto
    hence "Var y  δ ` (fv t)" using x by simp
    thus ?thesis using y inv_into_f_eq[OF δ_inj_on_t x y] unfolding subst_var_inv_def by simp
  qed
  thus ?thesis by (simp add: subst_compose_def trm_subst_ident'')
qed

text ‹Sufficient conditions for matching unifiable terms›
lemma inj_var_ran_unifiable_has_subst_match:
  assumes "t  δ = s  δ" "inj_on δ (fv t)" "δ ` fv t  range Var"
  shows "t = s  δ s subst_var_inv δ (fv t)"
using assms inj_var_ran_subst_is_invertible by fastforce

end

Theory Intruder_Deduction

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Intruder_Deduction.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹Dolev-Yao Intruder Model›
theory Intruder_Deduction
imports Messages More_Unification
begin

subsection ‹Syntax for the Intruder Deduction Relations›
consts INTRUDER_SYNTH::"('f,'v) terms  ('f,'v) term  bool" (infix "c" 50)
consts INTRUDER_DEDUCT::"('f,'v) terms  ('f,'v) term  bool" (infix "" 50)


subsection ‹Intruder Model Locale›
text ‹
  The intruder model is parameterized over arbitrary function symbols (e.g, cryptographic operators)
  and variables. It requires three functions:
  - arity› that assigns an arity to each function symbol.
  - public› that partitions the function symbols into those that will be available to the intruder
    and those that will not.
  - Ana›, the analysis interface, that defines how messages can be decomposed (e.g., decryption).
›
locale intruder_model =
  fixes arity :: "'fun  nat"
    and public :: "'fun  bool"
    and Ana :: "('fun,'var) term  (('fun,'var) term list × ('fun,'var) term list)"
  assumes Ana_keys_fv: "t K R. Ana t = (K,R)  fvset (set K)  fv t"
    and Ana_keys_wf: "t k K R f T.
      Ana t = (K,R)  (g S. Fun g S  t  length S = arity g)
                     k  set K  Fun f T  k  length T = arity f"
    and Ana_var[simp]: "x. Ana (Var x) = ([],[])"
    and Ana_fun_subterm: "f T K R. Ana (Fun f T) = (K,R)  set R  set T"
    and Ana_subst: "t δ K R. Ana t = (K,R); K  []  R  []  Ana (t  δ) = (K list δ,R list δ)"
begin

lemma Ana_subterm: assumes "Ana t = (K,T)" shows "set T  subterms t"
using assms
by (cases t)
   (simp add: psubsetI,
    metis Ana_fun_subterm Fun_gt_params UN_I term.order_refl
          params_subterms psubsetI subset_antisym subset_trans)

lemma Ana_subterm': "s  set (snd (Ana t))  s  t"
using Ana_subterm by (cases "Ana t") auto

lemma Ana_vars: assumes "Ana t = (K,M)" shows "fvset (set K)  fv t" "fvset (set M)  fv t"
by (rule Ana_keys_fv[OF assms]) (use Ana_subterm[OF assms] subtermeq_vars_subset in auto)

abbreviation 𝒱 where "𝒱  UNIV::'var set"
abbreviation Σn ("Σ⇧_") where "Σ⇧n  {f::'fun. arity f = n}"
abbreviation Σnpub ("Σpub_") where "Σpubn  {f. public f}  Σ⇧n"
abbreviation Σnpriv ("Σpriv_") where "Σprivn  {f. ¬public f}  Σ⇧n"
abbreviation Σpub where "Σpub  (n. Σpubn)"
abbreviation Σpriv where "Σpriv  (n. Σprivn)"
abbreviation Σ where "Σ  (n. Σ⇧n)"
abbreviation 𝒞 where "𝒞  Σ⇧0"
abbreviation 𝒞pub where "𝒞pub  {f. public f}  𝒞"
abbreviation 𝒞priv where "𝒞priv  {f. ¬public f}  𝒞"
abbreviation Σf where "Σf  Σ - 𝒞"
abbreviation Σfpub where "Σfpub  Σf  Σpub"
abbreviation Σfpriv where "Σfpriv  Σf  Σpriv"

lemma disjoint_fun_syms: f  𝒞 = {}" by auto
lemma id_union_univ: f  𝒞 = UNIV" = UNIV" by auto
lemma const_arity_eq_zero[dest]: "c  𝒞  arity c = 0" by simp
lemma const_pub_arity_eq_zero[dest]: "c  𝒞pub  arity c = 0  public c" by simp
lemma const_priv_arity_eq_zero[dest]: "c  𝒞priv  arity c = 0  ¬public c" by simp
lemma fun_arity_gt_zero[dest]: "f  Σf  arity f > 0" by fastforce
lemma pub_fun_public[dest]: "f  Σfpub  public f" by fastforce
lemma pub_fun_arity_gt_zero[dest]: "f  Σfpub  arity f > 0" by fastforce

lemma Σf_unfold: f = {f::'fun. arity f > 0}" by auto
lemma 𝒞_unfold: "𝒞 = {f::'fun. arity f = 0}" by auto
lemma 𝒞pub_unfold: "𝒞pub = {f::'fun. arity f = 0  public f}" by auto
lemma 𝒞priv_unfold: "𝒞priv = {f::'fun. arity f = 0  ¬public f}" by auto
lemma Σnpub_unfold: "(Σpubn) = {f::'fun. arity f = n  public f}" by auto
lemma Σnpriv_unfold: "(Σprivn) = {f::'fun. arity f = n  ¬public f}" by auto
lemma Σfpub_unfold: fpub = {f::'fun. arity f > 0  public f}" by auto
lemma Σfpriv_unfold: fpriv = {f::'fun. arity f > 0  ¬public f}" by auto
lemma Σn_m_eq: "(Σ⇧n)  {}; (Σ⇧n) = (Σ⇧m)  n = m" by auto


subsection ‹Term Well-formedness›
definition "wftrm t  f T. Fun f T  t  length T = arity f"

abbreviation "wftrms T  t  T. wftrm t"

lemma Ana_keys_wf': "Ana t = (K,T)  wftrm t  k  set K  wftrm k"
using Ana_keys_wf unfolding wftrm_def by metis

lemma wf_trm_Var[simp]: "wftrm (Var x)" unfolding wftrm_def by simp

lemma wf_trm_subst_range_Var[simp]: "wftrms (subst_range Var)" by simp

lemma wf_trm_subst_range_iff: "(x. wftrm (θ x))  wftrms (subst_range θ)"
by force

lemma wf_trm_subst_rangeD: "wftrms (subst_range θ)  wftrm (θ x)"
by (metis wf_trm_subst_range_iff)

lemma wf_trm_subst_rangeI[intro]:
  "(x. wftrm (δ x))  wftrms (subst_range δ)"
by (metis wf_trm_subst_range_iff)

lemma wf_trmI[intro]:
  assumes "t. t  set T  wftrm t" "length T = arity f"
  shows "wftrm (Fun f T)"
using assms unfolding wftrm_def by auto

lemma wf_trm_subterm: "wftrm t; s  t  wftrm s"
unfolding wftrm_def by (induct t) auto

lemma wf_trm_subtermeq:
  assumes "wftrm t" "s  t"
  shows "wftrm s"
proof (cases "s = t")
  case False thus "wftrm s" using assms(2) wf_trm_subterm[OF assms(1)] by simp
qed (metis assms(1))

lemma wf_trm_param:
  assumes "wftrm (Fun f T)" "t  set T"
  shows "wftrm t"
by (meson assms subtermeqI'' wf_trm_subtermeq)

lemma wf_trm_param_idx:
  assumes "wftrm (Fun f T)"
    and "i < length T"
  shows "wftrm (T ! i)"
using wf_trm_param[OF assms(1), of "T ! i"] assms(2)
by fastforce

lemma wf_trm_subst:
  assumes "wftrms (subst_range δ)"
  shows "wftrm t = wftrm (t  δ)"
proof
  show "wftrm t  wftrm (t  δ)"
  proof (induction t)
    case (Fun f T)
    hence "t. t  set T  wftrm t"
      by (meson wftrm_def Fun_param_is_subterm term.order_trans)
    hence "t. t  set T  wftrm (t  δ)" using Fun.IH by auto
    moreover have "length (map (λt. t  δ) T) = arity f"
      using Fun.prems unfolding wftrm_def by auto
    ultimately show ?case by fastforce
  qed (simp add: wf_trm_subst_rangeD[OF assms])

  show "wftrm (t  δ)  wftrm t"
  proof (induction t)
    case (Fun f T)
    hence "wftrm t" when "t  set (map (λs. s  δ) T)" for t
      by (metis that wftrm_def Fun_param_is_subterm term.order_trans subst_apply_term.simps(2)) 
    hence "wftrm t" when "t  set T" for t using that Fun.IH by auto
    moreover have "length (map (λt. t  δ) T) = arity f"
      using Fun.prems unfolding wftrm_def by auto
    ultimately show ?case by fastforce
  qed (simp add: assms)
qed

lemma wf_trm_subst_singleton:
  assumes "wftrm t" "wftrm t'" shows "wftrm (t  Var(v := t'))"
proof -
  have "wftrm ((Var(v := t')) w)" for w using assms(2) unfolding wftrm_def by simp
  thus ?thesis using assms(1) wf_trm_subst[of "Var(v := t')" t, OF wf_trm_subst_rangeI] by simp
qed

lemma wf_trm_subst_rm_vars:
  assumes "wftrm (t  δ)"
  shows "wftrm (t  rm_vars X δ)"
using assms
proof (induction t)
  case (Fun f T)
  have "wftrm (t  δ)" when "t  set T" for t
    using that wf_trm_param[of f "map (λt. t  δ) T"] Fun.prems
    by auto
  hence "wftrm (t  rm_vars X δ)" when "t  set T" for t using that Fun.IH by simp
  moreover have "length T = arity f" using Fun.prems unfolding wftrm_def by auto
  ultimately show ?case unfolding wftrm_def by auto
qed simp

lemma wf_trm_subst_rm_vars': "wftrm (δ v)  wftrm (rm_vars X δ v)"
by auto

lemma wf_trms_subst:
  assumes "wftrms (subst_range δ)" "wftrms M"
  shows "wftrms (M set δ)"
by (metis (no_types, lifting) assms imageE wf_trm_subst)

lemma wf_trms_subst_rm_vars:
  assumes "wftrms (M set δ)"
  shows "wftrms (M set rm_vars X δ)"
using assms wf_trm_subst_rm_vars by blast

lemma wf_trms_subst_rm_vars':
  assumes "wftrms (subst_range δ)"
  shows "wftrms (subst_range (rm_vars X δ))"
using assms by force  

lemma wf_trms_subst_compose:
  assumes "wftrms (subst_range θ)" "wftrms (subst_range δ)"
  shows "wftrms (subst_range (θ s δ))"
using assms subst_img_comp_subset' wf_trm_subst by blast 

lemma wf_trm_subst_compose:
  fixes δ::"('fun, 'v) subst"
  assumes "wftrm (θ x)" "x. wftrm (δ x)"
  shows "wftrm ((θ s δ) x)"
using wf_trm_subst[of δ "θ x", OF wf_trm_subst_rangeI[OF assms(2)]] assms(1)
      subst_subst_compose[of "Var x" θ δ]
      subst_apply_term.simps(1)[of x θ]
      subst_apply_term.simps(1)[of x "θ s δ"]
by argo

lemma wf_trms_Var_range:
  assumes "subst_range δ  range Var"
  shows "wftrms (subst_range δ)"
using assms by fastforce

lemma wf_trms_subst_compose_Var_range:
  assumes "wftrms (subst_range θ)"
    and "subst_range δ  range Var"
  shows "wftrms (subst_range (δ s θ))"
    and "wftrms (subst_range (θ s δ))"
using assms wf_trms_subst_compose wf_trms_Var_range by metis+

lemma wf_trm_subst_inv: "wftrm (t  δ)  wftrm t"
unfolding wftrm_def by (induct t) auto

lemma wf_trms_subst_inv: "wftrms (M set δ)  wftrms M"
using wf_trm_subst_inv by fast

lemma wf_trm_subterms: "wftrm t  wftrms (subterms t)"
using wf_trm_subterm by blast

lemma wf_trms_subterms: "wftrms M  wftrms (subtermsset M)"
using wf_trm_subterms by blast

lemma wf_trm_arity: "wftrm (Fun f T)  length T = arity f"
unfolding wftrm_def by blast

lemma wf_trm_subterm_arity: "wftrm t  Fun f T  t  length T = arity f"
unfolding wftrm_def by blast

lemma unify_list_wf_trm:
  assumes "Unification.unify E B = Some U" "(s,t)  set E. wftrm s  wftrm t"
  and "(v,t)  set B. wftrm t"
  shows "(v,t)  set U. wftrm t"
using assms
proof (induction E B arbitrary: U rule: Unification.unify.induct)
  case (1 B U) thus ?case by auto
next
  case (2 f T g S E B U)
  have wf_fun: "wftrm (Fun f T)" "wftrm (Fun g S)" using "2.prems"(2) by auto
  from "2.prems"(1) obtain E' where *: "decompose (Fun f T) (Fun g S) = Some E'"
    and [simp]: "f = g" "length T = length S" "E' = zip T S"
    and **: "Unification.unify (E'@E) B = Some U"
    by (auto split: option.splits)
  hence "t  Fun f T" "t'  Fun g S" when "(t,t')  set E'" for t t'
    using that by (metis zip_arg_subterm(1), metis zip_arg_subterm(2))
  hence "wftrm t" "wftrm t'" when "(t,t')  set E'" for t t'
    using wf_trm_subterm wf_fun f = g that by blast+
  thus ?case using "2.IH"[OF * ** _ "2.prems"(3)] "2.prems"(2) by fastforce
next
  case (3 v t E B)
  hence *: "(w,x)  set ((v, t) # B). wftrm x"
      and **: "(s,t)  set E. wftrm s  wftrm t" "wftrm t"
    by auto

  show ?case
  proof (cases "t = Var v")
    case True thus ?thesis using "3.prems" "3.IH"(1) by auto
  next
    case False
    hence "v  fv t" using "3.prems"(1) by auto
    hence "Unification.unify (subst_list (subst v t) E) ((v, t)#B) = Some U"
      using t  Var v "3.prems"(1) by auto
    moreover have "(s, t)  set (subst_list (subst v t) E). wftrm s  wftrm t"
      using wf_trm_subst_singleton[OF _ ‹wftrm t] "3.prems"(2)
      unfolding subst_list_def subst_def by auto
    ultimately show ?thesis using "3.IH"(2)[OF t  Var v v  fv t _ _ *] by metis
  qed
next
  case (4 f T v E B U)
  hence *: "(w,x)  set ((v, Fun f T) # B). wftrm x"
      and **: "(s,t)  set E. wftrm s  wftrm t" "wftrm (Fun f T)"
    by auto

  have "v  fv (Fun f T)" using "4.prems"(1) by force
  hence "Unification.unify (subst_list (subst v (Fun f T)) E) ((v, Fun f T)#B) = Some U"
    using "4.prems"(1) by auto
  moreover have "(s, t)  set (subst_list (subst v (Fun f T)) E). wftrm s  wftrm t"
    using wf_trm_subst_singleton[OF _ ‹wftrm (Fun f T)] "4.prems"(2)
    unfolding subst_list_def subst_def by auto
  ultimately show ?case using "4.IH"[OF v  fv (Fun f T) _ _ *] by metis
qed

lemma mgu_wf_trm:
  assumes "mgu s t = Some σ" "wftrm s" "wftrm t"
  shows "wftrm (σ v)"
proof -
  from assms obtain σ' where "subst_of σ' = σ" "(v,t)  set σ'. wftrm t"
    using unify_list_wf_trm[of "[(s,t)]" "[]"] by (auto split: option.splits)
  thus ?thesis
  proof (induction σ' arbitrary: σ v rule: List.rev_induct)
    case (snoc x σ' σ v)
    define θ where "θ = subst_of σ'"
    hence "wftrm (θ v)" for v using snoc.prems(2) snoc.IH[of θ] by fastforce 
    moreover obtain w t where x: "x = (w,t)" by (metis surj_pair) 
    hence σ: "σ = Var(w := t) s θ" using snoc.prems(1) by (simp add: subst_def θ_def)
    moreover have "wftrm t" using snoc.prems(2) x by auto
    ultimately show ?case using wf_trm_subst[of _ t] unfolding subst_compose_def by auto
  qed (simp add: wftrm_def)
qed

lemma mgu_wf_trms:
  assumes "mgu s t = Some σ" "wftrm s" "wftrm t"
  shows "wftrms (subst_range σ)"
using mgu_wf_trm[OF assms] by simp

subsection ‹Definitions: Intruder Deduction Relations›
text ‹
  A standard Dolev-Yao intruder.
›
inductive intruder_deduct::"('fun,'var) terms  ('fun,'var) term  bool"
where
  Axiom[simp]:   "t  M  intruder_deduct M t"
| Compose[simp]: "length T = arity f; public f; t. t  set T  intruder_deduct M t
                   intruder_deduct M (Fun f T)"
| Decompose:     "intruder_deduct M t; Ana t = (K, T); k. k  set K  intruder_deduct M k;
                   ti  set T
                   intruder_deduct M ti"

text ‹
  A variant of the intruder relation which limits the intruder to composition only.
›
inductive intruder_synth::"('fun,'var) terms  ('fun,'var) term  bool"
where
  AxiomC[simp]:   "t  M  intruder_synth M t"
| ComposeC[simp]: "length T = arity f; public f; t. t  set T  intruder_synth M t
                     intruder_synth M (Fun f T)"

adhoc_overloading INTRUDER_DEDUCT intruder_deduct
adhoc_overloading INTRUDER_SYNTH intruder_synth

lemma intruder_deduct_induct[consumes 1, case_names Axiom Compose Decompose]:
  assumes "M  t" "t. t  M  P M t"
          "T f. length T = arity f; public f;
                  t. t  set T  M  t;
                  t. t  set T  P M t  P M (Fun f T)"
          "t K T ti. M  t; P M t; Ana t = (K, T); k. k  set K  M  k;
                       k. k  set K  P M k; ti  set T  P M ti"
  shows "P M t"
using assms by (induct rule: intruder_deduct.induct) blast+

lemma intruder_synth_induct[consumes 1, case_names AxiomC ComposeC]:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
  assumes "M c t" "t. t  M  P M t"
          "T f. length T = arity f; public f;
                  t. t  set T  M c t;
                  t. t  set T  P M t  P M (Fun f T)"
  shows "P M t"
using assms by (induct rule: intruder_synth.induct) auto


subsection ‹Definitions: Analyzed Knowledge and Public Ground Well-formed Terms (PGWTs)›
definition analyzed::"('fun,'var) terms  bool" where
  "analyzed M  t. M  t  M c t"

definition analyzed_in where
  "analyzed_in t M  K R. (Ana t = (K,R)  (k  set K. M c k))  (r  set R. M c r)"

definition decomp_closure::"('fun,'var) terms  ('fun,'var) terms  bool" where
  "decomp_closure M M'  t. M  t  (t'  M. t  t')  t  M'"

inductive public_ground_wf_term::"('fun,'var) term  bool" where
  PGWT[simp]: "public f; arity f = length T;
                t. t  set T  public_ground_wf_term t
                   public_ground_wf_term (Fun f T)"

abbreviation "public_ground_wf_terms  {t. public_ground_wf_term t}"

lemma public_const_deduct:
  assumes "c  𝒞pub"
  shows "M  Fun c []" "M c Fun c []"
proof -
  have "arity c = 0" "public c" using const_arity_eq_zero c  𝒞pub by auto
  thus "M  Fun c []" "M c Fun c []"
    using intruder_synth.ComposeC[OF _ public c, of "[]"]
          intruder_deduct.Compose[OF _ public c, of "[]"]
    by auto
qed

lemma public_const_deduct'[simp]:
  assumes "arity c = 0" "public c"
  shows "M  Fun c []" "M c Fun c []"
using intruder_deduct.Compose[of "[]" c] intruder_synth.ComposeC[of "[]" c] assms by simp_all

lemma private_fun_deduct_in_ik:
  assumes t: "M  t" "Fun f T  subterms t"
    and f: "¬public f"
  shows "Fun f T  subtermsset M"
using t
proof (induction t rule: intruder_deduct.induct)
  case Decompose thus ?case by (meson Ana_subterm psubsetD term.order_trans)
qed (auto simp add: f in_subterms_Union)

lemma private_fun_deduct_in_ik':
  assumes t: "M  Fun f T"
    and f: "¬public f"
    and M: "Fun f T  subtermsset M  Fun f T  M"
  shows "Fun f T  M"
by (rule M[OF private_fun_deduct_in_ik[OF t term.order_refl f]])

lemma pgwt_public: "public_ground_wf_term t; Fun f T  t  public f"
by (induct t rule: public_ground_wf_term.induct) auto

lemma pgwt_ground: "public_ground_wf_term t  fv t = {}"
by (induct t rule: public_ground_wf_term.induct) auto

lemma pgwt_fun: "public_ground_wf_term t  f T. t = Fun f T"
using pgwt_ground[of t] by (cases t) auto

lemma pgwt_arity: "public_ground_wf_term t; Fun f T  t  arity f = length T"
by (induct t rule: public_ground_wf_term.induct) auto

lemma pgwt_wellformed: "public_ground_wf_term t  wftrm t"
by (induct t rule: public_ground_wf_term.induct) auto

lemma pgwt_deducible: "public_ground_wf_term t  M c t"
by (induct t rule: public_ground_wf_term.induct) auto

lemma pgwt_is_empty_synth: "public_ground_wf_term t  {} c t"
proof -
  { fix M::"('fun,'var) term set" assume "M c t" "M = {}" hence "public_ground_wf_term t"
      by (induct t rule: intruder_synth.induct) auto
  }
  thus ?thesis using pgwt_deducible by auto
qed

lemma ideduct_synth_subst_apply:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
  assumes "{} c t" "v. M c θ v"
  shows "M c t  θ"
proof -
  { fix M'::"('fun,'var) term set" assume "M' c t" "M' = {}" hence "M c t  θ"
    proof (induction t rule: intruder_synth.induct)
      case (ComposeC T f M')
      hence "length (map (λt. t  θ) T) = arity f" "x. x  set (map (λt. t  θ) T)  M c x"
        by auto
      thus ?case using intruder_synth.ComposeC[of "map (λt. t  θ) T" f M] public f by fastforce
    qed simp
  }
  thus ?thesis using assms by metis
qed
  

subsection ‹Lemmata: Monotonicity, deduction private constants, etc.›
context
begin
lemma ideduct_mono:
  "M  t; M  M'  M'  t"
proof (induction rule: intruder_deduct.induct)
  case (Decompose M t K T ti)
  have "k. k  set K  M'  k" using Decompose.IH M  M' by simp
  moreover have "M'  t" using Decompose.IH M  M' by simp
  ultimately show ?case using Decompose.hyps intruder_deduct.Decompose by blast
qed auto

lemma ideduct_synth_mono:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
  shows "M c t; M  M'  M' c t"
by (induct rule: intruder_synth.induct) auto

lemma ideduct_reduce:
  "M  M'  t; t'. t'  M'  M  t'  M  t"
proof (induction rule: intruder_deduct_induct)
  case Decompose thus ?case using intruder_deduct.Decompose by blast 
qed auto

lemma ideduct_synth_reduce:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
  shows "M  M' c t; t'. t'  M'  M c t'  M c t"
by (induct rule: intruder_synth_induct) auto

lemma ideduct_mono_eq:
  assumes "t. M  t  M'  t" shows "M  N  t  M'  N  t"
proof
  show "M  N  t  M'  N  t"
  proof (induction t rule: intruder_deduct_induct)
    case (Axiom t) thus ?case
    proof (cases "t  M")
      case True
      hence "M  t" using intruder_deduct.Axiom by metis
      thus ?thesis using assms ideduct_mono[of M' t "M'  N"] by simp
    qed auto
  next
    case (Compose T f) thus ?case using intruder_deduct.Compose by auto
  next
    case (Decompose t K T ti) thus ?case using intruder_deduct.Decompose[of "M'  N" t K T] by auto
  qed

  show "M'  N  t  M  N  t"
  proof (induction t rule: intruder_deduct_induct)
    case (Axiom t) thus ?case
    proof (cases "t  M'")
      case True
      hence "M'  t" using intruder_deduct.Axiom by metis
      thus ?thesis using assms ideduct_mono[of M t "M  N"] by simp
    qed auto
  next
    case (Compose T f) thus ?case using intruder_deduct.Compose by auto
  next
    case (Decompose t K T ti) thus ?case using intruder_deduct.Decompose[of "M  N" t K T] by auto
  qed
qed

lemma deduct_synth_subterm:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
  assumes "M c t" "s  subterms t" "m  M. s  subterms m. M c s"
  shows "M c s"
using assms by (induct t rule: intruder_synth.induct) auto

lemma deduct_if_synth[intro, dest]: "M c t  M  t"
by (induct rule: intruder_synth.induct) auto

private lemma ideduct_ik_eq: assumes "t  M. M'  t" shows "M'  t  M'  M  t"
by (meson assms ideduct_mono ideduct_reduce sup_ge1)

private lemma synth_if_deduct_empty: "{}  t  {} c t"
proof (induction t rule: intruder_deduct_induct)
  case (Decompose t K M m)
  then obtain f T where "t = Fun f T" "m  set T"
    using Ana_fun_subterm Ana_var by (cases t) fastforce+
  with Decompose.IH(1) show ?case by (induction rule: intruder_synth_induct) auto
qed auto

private lemma ideduct_deduct_synth_mono_eq:
  assumes "t. M  t  M' c t" "M  M'"
  and "t. M'  N  t  M'  N  D c t"
  shows "M  N  t  M'  N  D c t"
proof -
  have "m  M'. M  m" using assms(1) by auto
  hence "t. M  t  M'  t" by (metis assms(1,2) deduct_if_synth ideduct_reduce sup.absorb2)
  hence "t. M'  N  t  M  N  t" by (meson ideduct_mono_eq)
  thus ?thesis by (meson assms(3))
qed

lemma ideduct_subst: "M  t  M set δ  t  δ"
proof (induction t rule: intruder_deduct_induct)
  case (Compose T f)
  hence "length (map (λt. t  δ) T) = arity f" "t. t  set T  M set δ  t  δ" by auto
  thus ?case using intruder_deduct.Compose[OF _ Compose.hyps(2), of "map (λt. t  δ) T"] by auto
next
  case (Decompose t K M' m')
  hence "Ana (t  δ) = (K list δ, M' list δ)"
        "k. k  set (K list δ)  M set δ  k"
        "m'  δ  set (M' list δ)"
    using Ana_subst[OF Decompose.hyps(2)] by fastforce+
  thus ?case using intruder_deduct.Decompose[OF Decompose.IH(1)] by metis
qed simp

lemma ideduct_synth_subst:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term" and δ::"('fun,'var) subst"
  shows "M c t  M set δ c t  δ"
proof (induction t rule: intruder_synth_induct)
  case (ComposeC T f)
  hence "length (map (λt. t  δ) T) = arity f" "t. t  set T  M set δ c t  δ" by auto
  thus ?case using intruder_synth.ComposeC[OF _ ComposeC.hyps(2), of "map (λt. t  δ) T"] by auto
qed simp

lemma ideduct_vars:
  assumes "M  t"
  shows "fv t  fvset M"
using assms 
proof (induction t rule: intruder_deduct_induct)
  case (Decompose t K T ti) thus ?case
    using Ana_vars(2) fv_subset by blast 
qed auto

lemma ideduct_synth_vars:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
  assumes "M c t"
  shows "fv t  fvset M"
using assms by (induct t rule: intruder_synth_induct) auto

lemma ideduct_synth_priv_fun_in_ik:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
  assumes "M c t" "f  funs_term t" "¬public f"
  shows "f  (funs_term ` M)"
using assms by (induct t rule: intruder_synth_induct) auto

lemma ideduct_synth_priv_const_in_ik:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
  assumes "M c Fun c []" "¬public c"
  shows "Fun c []  M"
using intruder_synth.cases[OF assms(1)] assms(2) by fast

lemma ideduct_synth_ik_replace:
  fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
  assumes "t  M. N c t"
    and "M c t"
  shows "N c t"
using assms(2,1) by (induct t rule: intruder_synth.induct) auto
end

subsection ‹Lemmata: Analyzed Intruder Knowledge Closure›
lemma deducts_eq_if_analyzed: "analyzed M  M  t  M c t"
unfolding analyzed_def by auto

lemma closure_is_superset: "decomp_closure M M'  M  M'"
unfolding decomp_closure_def by force

lemma deduct_if_closure_deduct: "M'  t; decomp_closure M M'  M  t"
proof (induction t rule: intruder_deduct.induct)
  case (Decompose M' t K T ti)
  thus ?case using intruder_deduct.Decompose[OF _ Ana t = (K,T) _ ti  set T] by simp
qed (auto simp add: decomp_closure_def)

lemma deduct_if_closure_synth: "decomp_closure M M'; M' c t  M  t"
using deduct_if_closure_deduct by blast

lemma decomp_closure_subterms_composable:
  assumes "decomp_closure M M'"
  and "M' c t'" "M'  t" "t  t'"
  shows "M' c t"
using M' c t' assms
proof (induction t' rule: intruder_synth.induct)
  case (AxiomC t' M')
  have "M  t" using M'  t deduct_if_closure_deduct AxiomC.prems(1) by blast
  moreover
  { have "s  M. t'  s" using t'  M' AxiomC.prems(1) unfolding decomp_closure_def by blast
    hence "s  M. t  s" using t  t' term.order_trans by auto
  }
  ultimately have "t  M'" using AxiomC.prems(1) unfolding decomp_closure_def by blast
  thus ?case by simp
next
  case (ComposeC T f M')
  let ?t' = "Fun f T"
  { assume "t = ?t'" have "M' c t" using M' c ?t' t = ?t' by simp }
  moreover
  { assume "t  ?t'"
    have "x  set T. t  x" using t  ?t' t  ?t' by simp
    hence "M' c t" using ComposeC.IH ComposeC.prems(1,3) ComposeC.hyps(3) by blast
  }
  ultimately show ?case using cases_simp[of "t = ?t'" "M' c t"] by simp
qed

lemma decomp_closure_analyzed:
  assumes "decomp_closure M M'"
  shows "analyzed M'"
proof -
  { fix t assume "M'  t" have "M' c t" using M'  t assms
    proof (induction t rule: intruder_deduct.induct)
      case (Decompose M' t K T ti) 
      hence "M'  ti" using Decompose.hyps intruder_deduct.Decompose by blast
      moreover have "ti  t"
        using Decompose.hyps(4) Ana_subterm[OF Decompose.hyps(2)] by blast
      moreover have "M' c t" using Decompose.IH(1) Decompose.prems by blast
      ultimately show "M' c ti" using decomp_closure_subterms_composable Decompose.prems by blast
    qed auto
  }
  moreover have "t. M c t  M  t" by auto
  ultimately show ?thesis by (auto simp add: decomp_closure_def analyzed_def)
qed

lemma analyzed_if_all_analyzed_in:
  assumes M: "t  M. analyzed_in t M"
  shows "analyzed M"
proof (unfold analyzed_def, intro allI iffI)
  fix t
  assume t: "M  t"
  thus "M c t"
  proof (induction t rule: intruder_deduct_induct)
    case (Decompose t K T ti)
    { assume "t  M"
      hence ?case
        using M Decompose.IH(2) Decompose.hyps(2,4)
        unfolding analyzed_in_def by fastforce
    } moreover {
      fix f S assume "t = Fun f S" "s. s  set S  M c s"
      hence ?case using Ana_fun_subterm[of f S] Decompose.hyps(2,4) by blast
    } ultimately show ?case using intruder_synth.cases[OF Decompose.IH(1), of ?case] by blast
  qed simp_all
qed auto

lemma analyzed_is_all_analyzed_in:
  "(t  M. analyzed_in t M)  analyzed M"
proof
  show "analyzed M  t  M. analyzed_in t M"
    unfolding analyzed_in_def analyzed_def
    by (auto intro: intruder_deduct.Decompose[OF intruder_deduct.Axiom])
qed (rule analyzed_if_all_analyzed_in)

lemma ik_has_synth_ik_closure:
  fixes M :: "('fun,'var) terms"
  shows "M'. (t. M  t  M' c t)  decomp_closure M M'  (finite M  finite M')"
proof -
  let ?M' = "{t. M  t  (t'  M. t  t')}"

  have M'_closes: "decomp_closure M ?M'" unfolding decomp_closure_def by simp
  hence "M  ?M'" using closure_is_superset by simp

  have "t. ?M' c t  M  t" using deduct_if_closure_synth[OF M'_closes] by blast 
  moreover have "t. M  t  ?M'  t" using ideduct_mono[OF _ M  ?M'] by simp
  moreover have "analyzed ?M'" using decomp_closure_analyzed[OF M'_closes] .
  ultimately have "t. M  t  ?M' c t" unfolding analyzed_def by blast
  moreover have "finite M  finite ?M'" by auto
  ultimately show ?thesis using M'_closes by blast
qed


subsection ‹Intruder Variants: Numbered and Composition-Restricted Intruder Deduction Relations›
text ‹
  A variant of the intruder relation which restricts composition to only those terms that satisfy
  a given predicate Q.
›
inductive intruder_deduct_restricted::
  "('fun,'var) terms  (('fun,'var) term  bool)  ('fun,'var) term  bool"
  ("_;_ r _" 50)
where
  AxiomR[simp]:   "t  M  M; Q r t"
| ComposeR[simp]: "length T = arity f; public f; t. t  set T  M; Q r t; Q (Fun f T)
                     M; Q r Fun f T"
| DecomposeR:     "M; Q r t; Ana t = (K, T); k. k  set K  M; Q r k; ti  set T
                     M; Q r ti"

text ‹
  A variant of the intruder relation equipped with a number representing the heigth of the
  derivation tree (i.e., ⟨M; k⟩ ⊢n t› iff k is the maximum number of applications of the compose
  an decompose rules in any path of the derivation tree for M ⊢ t›).
›
inductive intruder_deduct_num::
  "('fun,'var) terms  nat  ('fun,'var) term  bool"
  ("_; _ n _" 50)
where
  AxiomN[simp]:   "t  M  M; 0 n t"
| ComposeN[simp]: "length T = arity f; public f; t. t  set T  M; steps t n t
                     M; Suc (Max (insert 0 (steps ` set T))) n Fun f T"
| DecomposeN:     "M; n n t; Ana t = (K, T); k. k  set K  M; steps k n k; ti  set T
                     M; Suc (Max (insert n (steps ` set K))) n ti"

lemma intruder_deduct_restricted_induct[consumes 1, case_names AxiomR ComposeR DecomposeR]:
  assumes "M; Q r t" "t. t  M  P M Q t"
          "T f. length T = arity f; public f;
                  t. t  set T  M; Q r t;
                  t. t  set T  P M Q t; Q (Fun f T)
                    P M Q (Fun f T)"
          "t K T ti. M; Q r t; P M Q t; Ana t = (K, T); k. k  set K  M; Q r k;
                       k. k  set K  P M Q k; ti  set T  P M Q ti"
  shows "P M Q t"
using assms by (induct t rule: intruder_deduct_restricted.induct) blast+

lemma intruder_deduct_num_induct[consumes 1, case_names AxiomN ComposeN DecomposeN]:
  assumes "M; n n t" "t. t  M  P M 0 t"
          "T f steps.
              length T = arity f; public f;
               t. t  set T  M; steps t n t;
               t. t  set T  P M (steps t) t
               P M (Suc (Max (insert 0 (steps ` set T)))) (Fun f T)"
          "t K T ti steps n.
              M; n n t; P M n t; Ana t = (K, T);
               k. k  set K  M; steps k n k;
               ti  set T; k. k  set K  P M (steps k) k
               P M (Suc (Max (insert n (steps ` set K)))) ti"
  shows "P M n t"
using assms by (induct rule: intruder_deduct_num.induct) blast+

lemma ideduct_restricted_mono:
  "M; P r t; M  M'  M'; P r t"
proof (induction rule: intruder_deduct_restricted_induct)
  case (DecomposeR t K T ti)
  have "k. k  set K  M'; P r k" using DecomposeR.IH M  M' by simp
  moreover have "M'; P r t" using DecomposeR.IH M  M' by simp
  ultimately show ?case
    using DecomposeR
          intruder_deduct_restricted.DecomposeR[OF _ DecomposeR.hyps(2) _ DecomposeR.hyps(4)]
    by blast
qed auto


subsection ‹Lemmata: Intruder Deduction Equivalences›
lemma deduct_if_restricted_deduct: "M;P r m  M  m"
proof (induction m rule: intruder_deduct_restricted_induct)
  case (DecomposeR t K T ti) thus ?case using intruder_deduct.Decompose by blast
qed simp_all

lemma restricted_deduct_if_restricted_ik:
  assumes "M;P r m" "m  M. P m"
  and P: "t t'. P t  t'  t  P t'"
  shows "P m"
using assms(1)
proof (induction m rule: intruder_deduct_restricted_induct)
  case (DecomposeR t K T ti)
  obtain f S where "t = Fun f S" using Ana_var ti  set T Ana t = (K, T) by (cases t) auto
  thus ?case using DecomposeR assms(2) P Ana_subterm by blast
qed (simp_all add: assms(2))

lemma deduct_restricted_if_synth:
  assumes P: "P m" "t t'. P t  t'  t  P t'"
  and m: "M c m"
  shows "M; P r m"
using m P(1)
proof (induction m rule: intruder_synth_induct)
  case (ComposeC T f)
  hence "M; P r t" when t: "t  set T" for t
    using t P(2) subtermeqI''[of _ T f]
    by fastforce
  thus ?case
    using intruder_deduct_restricted.ComposeR[OF ComposeC.hyps(1,2)] ComposeC.prems(1)
    by metis
qed simp

lemma deduct_zero_in_ik:
  assumes "M; 0 n t" shows "t  M"
proof -
  { fix k assume "M; k n t" hence "k > 0  t  M" by (induct t) auto
  } thus ?thesis using assms by auto
qed

lemma deduct_if_deduct_num: "M; k n t  M  t"
by (induct t rule: intruder_deduct_num.induct)
   (metis intruder_deduct.Axiom,
    metis intruder_deduct.Compose,
    metis intruder_deduct.Decompose)

lemma deduct_num_if_deduct: "M  t  k. M; k n t"
proof (induction t rule: intruder_deduct_induct)
  case (Compose T f)
  then obtain steps where *: "t  set T. M; steps t n t" by moura
  then obtain n where "t  set T. steps t  n"
    using finite_nat_set_iff_bounded_le[of "steps ` set T"]
    by auto
  thus ?case using ComposeN[OF Compose.hyps(1,2), of M steps] * by force
next
  case (Decompose t K T ti)
  hence "u. u  insert t (set K)  k. M; k n u" by auto
  then obtain steps where *: "M; steps t n t" "t  set K. M; steps t n t" by moura
  then obtain n where "steps t  n" "t  set K. steps t  n"
    using finite_nat_set_iff_bounded_le[of "steps ` insert t (set K)"]
    by auto
  thus ?case using DecomposeN[OF _ Decompose.hyps(2) _ Decompose.hyps(4), of M _ steps] * by force
qed (metis AxiomN)

lemma deduct_normalize:
  assumes M: "m  M. f T. Fun f T  m  P f T"
  and t: "M; k n t" "Fun f T  t" "¬P f T"
  shows "l  k. (M; l n Fun f T)  (t  set T. j < l. M; j n t)"
using t
proof (induction t rule: intruder_deduct_num_induct)
  case (AxiomN t) thus ?case using M by auto
next
  case (ComposeN T' f' steps) thus ?case
  proof (cases "Fun f' T' = Fun f T")
    case True
    hence "M; Suc (Max (insert 0 (steps ` set T'))) n Fun f T" "T = T'"
      using intruder_deduct_num.ComposeN[OF ComposeN.hyps] by auto
    moreover have "t. t  set T  M; steps t n t"
      using True ComposeN.hyps(3) by auto
    moreover have "t. t  set T  steps t < Suc (Max (insert 0 (steps ` set T)))"
      using Max_less_iff[of "insert 0 (steps ` set T)" "Suc (Max (insert 0 (steps ` set T)))"]
      by auto
    ultimately show ?thesis by auto
  next
    case False
    then obtain t' where t': "t'  set T'" "Fun f T  t'" using ComposeN by auto
    hence "l  steps t'. (M; l n Fun f T)  (t  set T. j < l. M; j n t)"
      using ComposeN.IH[OF _ _ ComposeN.prems(2)] by auto
    moreover have "steps t' < Suc (Max (insert 0 (steps ` set T')))"
      using Max_less_iff[of "insert 0 (steps ` set T')" "Suc (Max (insert 0 (steps ` set T')))"]
      using t'(1) by auto
    ultimately show ?thesis using ComposeN.hyps(3)[OF t'(1)]
      by (meson Suc_le_eq le_Suc_eq le_trans)
  qed
next
  case (DecomposeN t K T' ti steps n)
  hence *: "Fun f T  t"
    using term.order_trans[of "Fun f T" ti t] Ana_subterm[of t K T']
    by blast
  have "l  n. (M; l n Fun f T)  (t'  set T. j < l. M; j n t')"
    using DecomposeN.IH(1)[OF * DecomposeN.prems(2)] by auto
  moreover have "n < Suc (Max (insert n (steps ` set K)))"
      using Max_less_iff[of "insert n (steps ` set K)" "Suc (Max (insert n (steps ` set K)))"]
      by auto
  ultimately show ?case using DecomposeN.hyps(4) by (meson Suc_le_eq le_Suc_eq le_trans)
qed

lemma deduct_inv:
  assumes "M; n n t"
  shows "t  M 
         (f T. t = Fun f T  public f  length T = arity f  (t  set T. l < n. M; l n t)) 
         (m  subtermsset M.
            (l < n. M; l n m)  (k  set (fst (Ana m)). l < n. M; l n k) 
            t  set (snd (Ana m)))"
    (is "?P t n  ?Q t n  ?R t n")
using assms
proof (induction n arbitrary: t rule: nat_less_induct)
  case (1 n t) thus ?case
  proof (cases n)
    case 0
    hence "t  M" using deduct_zero_in_ik "1.prems"(1) by metis
    thus ?thesis by auto
  next
    case (Suc n')
    hence "M; Suc n' n t"
          "m < Suc n'. x. (M; m n x)  ?P x m  ?Q x m  ?R x m"
      using "1.prems" "1.IH" by blast+
    hence "?P t (Suc n')  ?Q t (Suc n')  ?R t (Suc n')"
    proof (induction t rule: intruder_deduct_num_induct)
      case (AxiomN t) thus ?case by simp
    next
      case (ComposeN T f steps)
      have "t. t  set T  steps t < Suc (Max (insert 0 (steps ` set T)))"
          using Max_less_iff[of "insert 0 (steps ` set T)" "Suc (Max (insert 0 (steps ` set T)))"]
          by auto
      thus ?case using ComposeN.hyps by metis
    next
      case (DecomposeN t K T ti steps n)
      have 0: "n < Suc (Max (insert n (steps ` set K)))"
              "k. k  set K  steps k < Suc (Max (insert n (steps ` set K)))"
        using Max_less_iff[of "insert n (steps ` set K)" "Suc (Max (insert n (steps ` set K)))"]
        by auto

      have IH1: "?P t j  ?Q t j  ?R t j" when jt: "j < n" "M; j n t" for j t
        using jt DecomposeN.prems(1) 0(1)
        by simp

      have IH2: "?P t n  ?Q t n  ?R t n"
        using DecomposeN.IH(1) IH1
        by simp

      have 1: "k  set (fst (Ana t)). l < Suc (Max (insert n (steps ` set K))). M; l n k"
        using DecomposeN.hyps(1,2,3) 0(2)
        by auto
    
      have 2: "ti  set (snd (Ana t))"
        using DecomposeN.hyps(2,4)
        by fastforce
    
      have 3: "t  subtermsset M" when "t  set (snd (Ana m))" "m set M" for m
        using that(1) Ana_subterm[of m _ "snd (Ana m)"] in_subterms_subset_Union[OF that(2)]
        by (metis (no_types, lifting) prod.collapse psubsetD subsetCE subsetD) 
    
      have 4: "?R ti (Suc (Max (insert n (steps ` set K))))" when "?R t n"
        using that 0(1) 1 2 3 DecomposeN.hyps(1)
        by (metis (no_types, lifting)) 
    
      have 5: "?R ti (Suc (Max (insert n (steps ` set K))))" when "?P t n"
        using that 0(1) 1 2 DecomposeN.hyps(1)
        by blast
    
      have 6: ?case when *: "?Q t n"
      proof -
        obtain g S where g:
            "t = Fun g S" "public g" "length S = arity g" "t  set S. l < n. M; l n t"
          using * by moura
        then obtain l where l: "l < n" "M; l n ti"
          using 0(1) DecomposeN.hyps(2,4) Ana_fun_subterm[of g S K T] by blast
    
        have **: "l < Suc (Max (insert n (steps ` set K)))" using l(1) 0(1) by simp
    
        show ?thesis using IH1[OF l] less_trans[OF _ **] by fastforce
      qed

      show ?case using IH2 4 5 6 by argo
    qed
    thus ?thesis using Suc by fast
  qed
qed

lemma restricted_deduct_if_deduct:
  assumes M: "m  M. f T. Fun f T  m  P (Fun f T)"
  and P_subterm: "f T t. M  Fun f T  P (Fun f T)  t  set T  P t"
  and P_Ana_key: "t K T k. M  t  P t  Ana t = (K, T)  M  k  k  set K  P k"
  and m: "M  m" "P m"
  shows "M; P r m"
proof -
  { fix k assume "M; k n m"
    hence ?thesis using m(2)
    proof (induction k arbitrary: m rule: nat_less_induct)
      case (1 n m) thus ?case
      proof (cases n)
        case 0
        hence "m  M" using deduct_zero_in_ik "1.prems"(1) by metis
        thus ?thesis by auto
      next
        case (Suc n')
        hence "M; Suc n' n m"
              "m < Suc n'. x. (M; m n x)  P x  M;P r x"
          using "1.prems" "1.IH" by blast+
        thus ?thesis using "1.prems"(2)
        proof (induction m rule: intruder_deduct_num_induct)
          case (ComposeN T f steps)
          have *: "steps t < Suc (Max (insert 0 (steps ` set T)))" when "t  set T" for t
            using Max_less_iff[of "insert 0 (steps ` set T)"] that
            by blast

          have **: "P t" when "t  set T" for t
            using P_subterm ComposeN.prems(2) that
                  Fun_param_is_subterm[OF that]
                  intruder_deduct.Compose[OF ComposeN.hyps(1,2)]
                  deduct_if_deduct_num[OF ComposeN.hyps(3)]
            by blast

          have "M; P r t" when "t  set T" for t
            using ComposeN.prems(1) ComposeN.hyps(3)[OF that] *[OF that] **[OF that]
            by blast
          thus ?case
            by (metis intruder_deduct_restricted.ComposeR[OF ComposeN.hyps(1,2)] ComposeN.prems(2))
        next
          case (DecomposeN t K T ti steps l)
          show ?case
          proof (cases "P t")
            case True
            hence "k. k  set K  P k"
              using P_Ana_key DecomposeN.hyps(1,2,3) deduct_if_deduct_num
              by blast
            moreover have
                "k m x. k  set K  m < steps k  M; m n x  P x  M;P r x"
            proof -
              fix k m x assume *: "k  set K" "m < steps k" "M; m n x" "P x"
              have "steps k  insert l (steps ` set K)" using *(1) by simp
              hence "m < Suc (Max (insert l (steps ` set K)))"
                using less_trans[OF *(2), of "Suc (Max (insert l (steps ` set K)))"]
                      Max_less_iff[of "insert l (steps ` set K)"
                                      "Suc (Max (insert l (steps ` set K)))"]
                by auto
              thus "M;P r x" using DecomposeN.prems(1) *(3,4) by simp
            qed
            ultimately have "k. k  set K  M; P r k"
              using DecomposeN.IH(2) by auto
            moreover have "M; P r t"
              using True DecomposeN.prems(1) DecomposeN.hyps(1) le_imp_less_Suc
                    Max_less_iff[of "insert l (steps ` set K)" "Suc (Max (insert l (steps ` set K)))"]
              by blast
            ultimately show ?thesis
              using intruder_deduct_restricted.DecomposeR[OF _ DecomposeN.hyps(2)
                                                             _ DecomposeN.hyps(4)]
              by metis
          next
            case False
            obtain g S where gS: "t = Fun g S" using DecomposeN.hyps(2,4) by (cases t) moura+
            hence *: "Fun g S  t" "¬P (Fun g S)" using False by force+
            have "j<l. M; j n ti"
              using gS DecomposeN.hyps(2,4) Ana_fun_subterm[of g S K T]
                    deduct_normalize[of M "λf T. P (Fun f T)", OF M DecomposeN.hyps(1) *]
              by force
            hence "j<Suc (Max (insert l (steps ` set K))). M; j n ti"
              using Max_less_iff[of "insert l (steps ` set K)"
                                    "Suc (Max (insert l (steps ` set K)))"]
                    less_trans[of _ l "Suc (Max (insert l (steps ` set K)))"]
              by blast
            thus ?thesis using DecomposeN.prems(1,2) by meson
          qed
        qed auto
      qed
    qed
  } thus ?thesis using deduct_num_if_deduct m(1) by metis
qed

lemma restricted_deduct_if_deduct':
  assumes "m  M. P m"
    and "t t'. P t  t'  t  P t'"
    and "t K T k. P t  Ana t = (K, T)  k  set K  P k"
    and "M  m" "P m"
  shows "M; P r m"
using restricted_deduct_if_deduct[of M P m] assms
by blast

lemma private_const_deduct:
  assumes c: "¬public c" "M  (Fun c []::('fun,'var) term)"
  shows "Fun c []  M 
         (m  subtermsset M. M  m  (k  set (fst (Ana m)). M  m) 
                             Fun c []  set (snd (Ana m)))"
proof -
  obtain n where "M; n n Fun c []"
    using c(2) deduct_num_if_deduct by moura
  hence "Fun c []  M 
         (m  subtermsset M.
            (l < n. M; l n m) 
            (k  set (fst (Ana m)). l < n. M; l n k)  Fun c []  set (snd (Ana m)))"
    using deduct_inv[of M n "Fun c []"] c(1) by fast
  thus ?thesis using deduct_if_deduct_num[of M] by blast
qed

lemma private_fun_deduct_in_ik'':
  assumes t: "M  Fun f T" "Fun c []  set T" "m  subtermsset M. Fun f T  set (snd (Ana m))"
    and c: "¬public c" "Fun c []  M" "m  subtermsset M. Fun c []  set (snd (Ana m))"
  shows "Fun f T  M"
proof -
  have *: "n. M; n n Fun c []"
    using private_const_deduct[OF c(1)] c(2,3) deduct_if_deduct_num
    by blast

  obtain n where n: "M; n n Fun f T"
    using t(1) deduct_num_if_deduct
    by blast

  show ?thesis
    using deduct_inv[OF n] t(2,3) *
    by blast
qed

end

subsection ‹Executable Definitions for Code Generation›
fun intruder_synth' where
  "intruder_synth' pu ar M (Var x) = (Var x  M)"
| "intruder_synth' pu ar M (Fun f T) = (
    Fun f T  M  (pu f  length T = ar f  list_all (intruder_synth' pu ar M) T))"

definition "wftrm' ar t  (s  subterms t. is_Fun s  ar (the_Fun s) = length (args s))"

definition "wftrms' ar M  (t  M. wftrm' ar t)"

definition "analyzed_in' An pu ar t M  (case An t of
    (K,T)  (k  set K. intruder_synth' pu ar M k)  (s  set T. intruder_synth' pu ar M s))"

lemma (in intruder_model) intruder_synth'_induct[consumes 1, case_names Var Fun]:
  assumes "intruder_synth' public arity M t"
          "x. intruder_synth' public arity M (Var x)  P (Var x)"
          "f T. (z. z  set T  intruder_synth' public arity M z  P z) 
                  intruder_synth' public arity M (Fun f T)  P (Fun f T) "
  shows "P t"
using assms by (induct public arity M t rule: intruder_synth'.induct) auto

lemma (in intruder_model) wftrm_code[code_unfold]:
  "wftrm t = wftrm' arity t"
unfolding wftrm_def wftrm'_def
by auto

lemma (in intruder_model) wftrms_code[code_unfold]:
  "wftrms M = wftrms' arity M"
using wftrm_code
unfolding wftrms'_def
by auto

lemma (in intruder_model) intruder_synth_code[code_unfold]:
  "intruder_synth M t = intruder_synth' public arity M t"
  (is "?A  ?B")
proof
  show "?A  ?B"
  proof (induction t rule: intruder_synth_induct)
    case (AxiomC t) thus ?case by (cases t) auto
  qed (fastforce simp add: list_all_iff)

  show "?B  ?A"
  proof (induction t rule: intruder_synth'_induct)
    case (Fun f T) thus ?case
    proof (cases "Fun f T  M")
      case False
      hence "public f" "length T = arity f" "list_all (intruder_synth' public arity M) T"
        using Fun.hyps by fastforce+
      thus ?thesis
        using Fun.IH intruder_synth.ComposeC[of T f M] Ball_set[of T]
        by blast
    qed simp
  qed simp
qed

lemma (in intruder_model) analyzed_in_code[code_unfold]:
  "analyzed_in t M = analyzed_in' Ana public arity t M"
using intruder_synth_code[of M]
unfolding analyzed_in_def analyzed_in'_def
by fastforce

end

Theory Strands_and_Constraints

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Strands_and_Constraints.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹Strands and Symbolic Intruder Constraints›
theory Strands_and_Constraints
imports Messages More_Unification Intruder_Deduction
begin

subsection ‹Constraints, Strands and Related Definitions›
datatype poscheckvariant = Assign ("assign") | Check ("check")

text ‹
  A strand (or constraint) step is either a message transmission (either a message being sent Send›
  or being received Receive›) or a check on messages (a positive check Equality›---which can be
  either an "assignment" or just a check---or a negative check Inequality›)
›
datatype (funsstp: 'a, varsstp: 'b) strand_step =
  Send       "('a,'b) term" ("send⟨_st" 80)
| Receive    "('a,'b) term" ("receive⟨_st" 80)
| Equality   poscheckvariant "('a,'b) term" "('a,'b) term" ("_: _  _st" [80,80])
| Inequality (bvarsstp: "'b list") "(('a,'b) term × ('a,'b) term) list" ("_⟨∨≠: _st" [80,80])
where
  "bvarsstp (Send _) = []"
| "bvarsstp (Receive _) = []"
| "bvarsstp (Equality _ _ _) = []"

text ‹
  A strand is a finite sequence of strand steps (constraints and strands share the same datatype)
›
type_synonym ('a,'b) strand = "('a,'b) strand_step list"

type_synonym ('a,'b) strands = "('a,'b) strand set"

abbreviation "trmspairs F  (t,t')  set F. {t,t'}"

fun trmsstp::"('a,'b) strand_step  ('a,'b) terms" where
  "trmsstp (Send t) = {t}"
| "trmsstp (Receive t) = {t}"
| "trmsstp (Equality _ t t') = {t,t'}"
| "trmsstp (Inequality _ F) = trmspairs F"

lemma varsstp_unfold[simp]: "varsstp x = fvset (trmsstp x)  set (bvarsstp x)"
by (cases x) auto

text ‹The set of terms occurring in a strand›
definition trmsst where "trmsst S  (trmsstp ` set S)"

fun trms_liststp::"('a,'b) strand_step  ('a,'b) term list" where
  "trms_liststp (Send t) = [t]"
| "trms_liststp (Receive t) = [t]"
| "trms_liststp (Equality _ t t') = [t,t']"
| "trms_liststp (Inequality _ F) = concat (map (λ(t,t'). [t,t']) F)"

text ‹The set of terms occurring in a strand (list variant)›
definition trms_listst where "trms_listst S  remdups (concat (map trms_liststp S))"

text ‹The set of variables occurring in a sent message›
definition fvsnd::"('a,'b) strand_step  'b set" where
  "fvsnd x  case x of Send t  fv t | _  {}"

text ‹The set of variables occurring in a received message›
definition fvrcv::"('a,'b) strand_step  'b set" where
  "fvrcv x  case x of Receive t  fv t | _  {}"

text ‹The set of variables occurring in an equality constraint›
definition fveq::"poscheckvariant  ('a,'b) strand_step  'b set" where
  "fveq ac x  case x of Equality ac' s t  if ac = ac' then fv s  fv t else {} | _  {}"

text ‹The set of variables occurring at the left-hand side of an equality constraint›
definition fv_leq::"poscheckvariant  ('a,'b) strand_step  'b set" where
  "fv_leq ac x  case x of Equality ac' s t  if ac = ac' then fv s else {} | _  {}"

text ‹The set of variables occurring at the right-hand side of an equality constraint›
definition fv_req::"poscheckvariant  ('a,'b) strand_step  'b set" where
  "fv_req ac x  case x of Equality ac' s t  if ac = ac' then fv t else {} | _  {}"

text ‹The free variables of inequality constraints›
definition fvineq::"('a,'b) strand_step  'b set" where
  "fvineq x  case x of Inequality X F  fvpairs F - set X | _  {}"

fun fvstp::"('a,'b) strand_step  'b set" where
  "fvstp (Send t) = fv t"
| "fvstp (Receive t) = fv t"
| "fvstp (Equality _ t t') = fv t  fv t'"
| "fvstp (Inequality X F) = ((t,t')  set F. fv t  fv t') - set X"

text ‹The set of free variables of a strand›
definition fvst::"('a,'b) strand  'b set" where
  "fvst S  (set (map fvstp S))"

text ‹The set of bound variables of a strand›
definition bvarsst::"('a,'b) strand  'b set" where
  "bvarsst S  (set (map (set  bvarsstp) S))"

text ‹The set of all variables occurring in a strand›
definition varsst::"('a,'b) strand  'b set" where
  "varsst S  (set (map varsstp S))"

abbreviation wfrestrictedvarsstp::"('a,'b) strand_step  'b set" where
  "wfrestrictedvarsstp x 
    case x of Inequality _ _  {} | Equality Check _ _  {} | _  varsstp x"

text ‹The variables of a strand whose occurrences might be restricted by well-formedness constraints›
definition wfrestrictedvarsst::"('a,'b) strand  'b set" where
  "wfrestrictedvarsst S  (set (map wfrestrictedvarsstp S))"

abbreviation wfvarsoccsstp where
  "wfvarsoccsstp x  case x of Send t  fv t | Equality Assign s t  fv s | _  {}"

text ‹The variables of a strand that occur in sent messages or as variables in assignments›
definition wfvarsoccsst where
  "wfvarsoccsst S  (set (map wfvarsoccsstp S))"

text ‹The variables occurring at the right-hand side of assignment steps›
fun assignment_rhsst where
  "assignment_rhsst [] = {}"
| "assignment_rhsst (Equality Assign t t'#S) = insert t' (assignment_rhsst S)"
| "assignment_rhsst (x#S) = assignment_rhsst S"

text ‹The set function symbols occurring in a strand›
definition funsst::"('a,'b) strand  'a set" where
  "funsst S  (set (map funsstp S))"

fun subst_apply_strand_step::"('a,'b) strand_step  ('a,'b) subst  ('a,'b) strand_step"
  (infix "stp" 51) where
  "Send t stp θ = Send (t  θ)"
| "Receive t stp θ = Receive (t  θ)"
| "Equality a t t' stp θ = Equality a (t  θ) (t'  θ)"
| "Inequality X F stp θ = Inequality X (F pairs rm_vars (set X) θ)"

text ‹Substitution application for strands›
definition subst_apply_strand::"('a,'b) strand  ('a,'b) subst  ('a,'b) strand"
  (infix "st" 51) where
  "S st θ  map (λx. x stp θ) S"

text ‹The semantics of inequality constraints›
definition
  "ineq_model (::('a,'b) subst) X F 
      (δ. subst_domain δ = set X  ground (subst_range δ)  
              list_ex (λf. fst f  (δ s )  snd f  (δ s )) F)"

fun simplestp where
  "simplestp (Receive t) = True"
| "simplestp (Send (Var v)) = True"
| "simplestp (Inequality X F) = (. ineq_model  X F)"
| "simplestp _ = False"

text ‹Simple constraints›
definition simple where "simple S  list_all simplestp S"

text ‹The intruder knowledge of a constraint›
fun ikst::"('a,'b) strand  ('a,'b) terms" where
  "ikst [] = {}"
| "ikst (Receive t#S) = insert t (ikst S)"
| "ikst (_#S) = ikst S"

text ‹Strand well-formedness›
fun wfst::"'b set  ('a,'b) strand  bool" where
  "wfst V [] = True"
| "wfst V (Receive t#S) = (fv t  V  wfst V S)"
| "wfst V (Send t#S) = wfst (V  fv t) S"
| "wfst V (Equality Assign s t#S) = (fv t  V  wfst (V  fv s) S)"
| "wfst V (Equality Check s t#S) = wfst V S"
| "wfst V (Inequality _ _#S) = wfst V S"

text ‹Well-formedness of constraint states›
definition wfconstr::"('a,'b) strand  ('a,'b) subst  bool" where
  "wfconstr S θ  (wfsubst θ  wfst {} S  subst_domain θ  varsst S = {} 
                  range_vars θ  bvarsst S = {}  fvst S  bvarsst S = {})"

declare trmsst_def[simp]
declare fvsnd_def[simp]
declare fvrcv_def[simp]
declare fveq_def[simp]
declare fv_leq_def[simp]
declare fv_req_def[simp]
declare fvineq_def[simp]
declare fvst_def[simp]
declare varsst_def[simp]
declare bvarsst_def[simp]
declare wfrestrictedvarsst_def[simp]
declare wfvarsoccsst_def[simp]

lemmas wfst_induct = wfst.induct[case_names Nil ConsRcv ConsSnd ConsEq ConsEq2 ConsIneq]
lemmas ikst_induct = ikst.induct[case_names Nil ConsRcv ConsSnd ConsEq ConsIneq]
lemmas assignment_rhsst_induct = assignment_rhsst.induct[case_names Nil ConsEq2 ConsSnd ConsRcv ConsEq ConsIneq]
  

subsubsection ‹Lexicographical measure on strands›
definition sizest::"('a,'b) strand  nat" where
  "sizest S  size_list (λx. Max (insert 0 (size ` trmsstp x))) S"

definition measurest::"((('a, 'b) strand × ('a,'b) subst) × ('a, 'b) strand × ('a,'b) subst) set"
where
  "measurest  measures [λ(S,θ). card (fvst S), λ(S,θ). sizest S]"

lemma measurest_alt_def:
  "((s,x),(t,y))  measurest =
      (card (fvst s) < card (fvst t)  (card (fvst s) = card (fvst t)  sizest s < sizest t))"
by (simp add: measurest_def sizest_def)

lemma measurest_trans: "trans measurest"
by (simp add: trans_def measurest_def sizest_def)


subsubsection ‹Some lemmata›
lemma trms_listst_is_trmsst: "trmsst S = set (trms_listst S)"
unfolding trmsst_def trms_listst_def
proof (induction S)
  case (Cons x S) thus ?case by (cases x) auto
qed simp

lemma subst_apply_strand_step_def:
  "s stp θ = (case s of
    Send t  Send (t  θ)
  | Receive t  Receive (t  θ)
  | Equality a t t'  Equality a (t  θ) (t'  θ)
  | Inequality X F  Inequality X (F pairs rm_vars (set X) θ))"
by (cases s) simp_all

lemma subst_apply_strand_nil[simp]: "[] st δ = []"
unfolding subst_apply_strand_def by simp

lemma finite_funsstp[simp]: "finite (funsstp x)" by (cases x) auto
lemma finite_funsst[simp]: "finite (funsst S)" unfolding funsst_def by simp
lemma finite_trmspairs[simp]: "finite (trmspairs x)" by (induct x) auto
lemma finite_trmsstp[simp]: "finite (trmsstp x)" by (cases x) auto
lemma finite_varsstp[simp]: "finite (varsstp x)" by auto
lemma finite_bvarsstp[simp]: "finite (set (bvarsstp x))" by rule
lemma finite_fvsnd[simp]: "finite (fvsnd x)" by (cases x) auto
lemma finite_fvrcv[simp]: "finite (fvrcv x)" by (cases x) auto
lemma finite_fvstp[simp]: "finite (fvstp x)" by (cases x) auto
lemma finite_varsst[simp]: "finite (varsst S)" by simp
lemma finite_bvarsst[simp]: "finite (bvarsst S)" by simp
lemma finite_fvst[simp]: "finite (fvst S)" by simp

lemma finite_wfrestrictedvarsstp[simp]: "finite (wfrestrictedvarsstp x)"
by (cases x) (auto split: poscheckvariant.splits)

lemma finite_wfrestrictedvarsst[simp]: "finite (wfrestrictedvarsst S)"
using finite_wfrestrictedvarsstp by auto

lemma finite_wfvarsoccsstp[simp]: "finite (wfvarsoccsstp x)"
by (cases x) (auto split: poscheckvariant.splits)

lemma finite_wfvarsoccsst[simp]: "finite (wfvarsoccsst S)"
using finite_wfvarsoccsstp by auto

lemma finite_ikst[simp]: "finite (ikst S)"
by (induct S rule: ikst.induct) simp_all

lemma finite_assignment_rhsst[simp]: "finite (assignment_rhsst S)"
by (induct S rule: assignment_rhsst.induct) simp_all

lemma ikst_is_rcv_set: "ikst A = {t. Receive t  set A}"
by (induct A rule: ikst.induct) auto

lemma ikstD[dest]: "t  ikst S  Receive t  set S"
by (induct S rule: ikst.induct) auto

lemma ikstD'[dest]: "t  ikst S  t  trmsst S"
by (induct S rule: ikst.induct) auto

lemma ikstD''[dest]: "t  subtermsset (ikst S)  t  subtermsset (trmsst S)"
by (induct S rule: ikst.induct) auto

lemma ikst_subterm_exD:
  assumes "t  ikst S"
  shows "x  set S. t  subtermsset (trmsstp x)"
using assms ikstD by force

lemma assignment_rhsstD[dest]: "t  assignment_rhsst S  t'. Equality Assign t' t  set S"
by (induct S rule: assignment_rhsst.induct) auto

lemma assignment_rhsstD'[dest]: "t  subtermsset (assignment_rhsst S)  t  subtermsset (trmsst S)"
by (induct S rule: assignment_rhsst.induct) auto

lemma bvarsst_split: "bvarsst (S@S') = bvarsst S  bvarsst S'"
unfolding bvarsst_def by auto

lemma bvarsst_singleton: "bvarsst [x] = set (bvarsstp x)"
unfolding bvarsst_def by auto

lemma strand_fv_bvars_disjointD:
  assumes "fvst S  bvarsst S = {}" "Inequality X F  set S"
  shows "set X  bvarsst S" "fvpairs F - set X  fvst S"
using assms by (induct S) fastforce+

lemma strand_fv_bvars_disjoint_unfold:
  assumes "fvst S  bvarsst S = {}" "Inequality X F  set S" "Inequality Y G  set S"
  shows "set Y  (fvpairs F - set X) = {}"
proof -
  have "set X  bvarsst S" "set Y  bvarsst S"
       "fvpairs F - set X  fvst S" "fvpairs G - set Y  fvst S"
    using strand_fv_bvars_disjointD[OF assms(1)] assms(2,3) by auto
  thus ?thesis using assms(1) by fastforce
qed

lemma strand_subst_hom[iff]:
  "(S@S') st θ = (S st θ)@(S' st θ)" "(x#S) st θ = (x stp θ)#(S st θ)"
unfolding subst_apply_strand_def by auto

lemma strand_subst_comp: "range_vars δ  bvarsst S = {}  S st δ s θ = ((S st δ) st θ)"
proof (induction S)
  case (Cons x S)
  have *: "range_vars δ  bvarsst S = {}" "range_vars δ  (set (bvarsstp x)) = {}"
    using Cons bvarsst_split[of "[x]" S] append_Cons inf_sup_absorb
    by (metis (no_types, lifting) Int_iff Un_commute disjoint_iff_not_equal self_append_conv2,
        metis append_self_conv2 bvarsst_singleton inf_bot_right inf_left_commute) 
  hence IH: "S st δ s θ = (S st δ) st θ" using Cons.IH by auto
  have "(x#S st δ s θ) = (x stp δ s θ)#(S st δ s θ)" by (metis strand_subst_hom(2))
  hence "... = (x stp δ s θ)#((S st δ) st θ)" by (metis IH)
  hence "... = ((x stp δ) stp θ)#((S st δ) st θ)" using rm_vars_comp[OF *(2)]
  proof (induction x)
    case (Inequality X F) thus ?case
      by (induct F) (auto simp add: subst_apply_pairs_def subst_apply_strand_step_def)
  qed (simp_all add: subst_apply_strand_step_def)
  thus ?case using IH by auto
qed (simp add: subst_apply_strand_def)

lemma strand_substI[intro]:
  "subst_domain θ  fvst S = {}  S st θ = S"
  "subst_domain θ  varsst S = {}  S st θ = S"
proof -
  show "subst_domain θ  varsst S = {}  S st θ = S"
  proof (induction S)
    case (Cons x S)
    hence "S st θ = S" by auto
    moreover have "varsstp x  subst_domain θ = {}" using Cons.prems by auto
    hence "x stp θ = x"
    proof (induction x)
      case (Inequality X F) thus ?case
        by (induct F) (force simp add: subst_apply_pairs_def)+
    qed auto
    ultimately show ?case by simp
  qed (simp add: subst_apply_strand_def)

  show "subst_domain θ  fvst S = {}  S st θ = S"
  proof (induction S)
    case (Cons x S)
    hence "S st θ = S" by auto
    moreover have "fvstp x  subst_domain θ = {}"
      using Cons.prems by auto
    hence "x stp θ = x"
    proof (induction x)
      case (Inequality X F) thus ?case
        by (induct F) (force simp add: subst_apply_pairs_def)+
    qed auto
    ultimately show ?case by simp
  qed (simp add: subst_apply_strand_def)
qed

lemma strand_substI':
  "fvst S = {}  S st θ = S"
  "varsst S = {}  S st θ = S"
by (metis inf_bot_right strand_substI(1),
    metis inf_bot_right strand_substI(2))

lemma strand_subst_set: "(set (S st θ)) = ((λx. x stp θ) ` (set S))"
by (auto simp add: subst_apply_strand_def)

lemma strand_map_inv_set_snd_rcv_subst:
  assumes "finite (M::('a,'b) terms)"
  shows "set ((map Send (inv set M)) st θ) = Send ` (M set θ)" (is ?A)
        "set ((map Receive (inv set M)) st θ) = Receive ` (M set θ)" (is ?B)
proof -
  { fix f::"('a,'b) term  ('a,'b) strand_step" assume f: "f = Send  f = Receive"
    from assms have "set ((map f (inv set M)) st θ) = f ` (M set θ)"
    proof (induction rule: finite_induct)
      case empty thus ?case unfolding inv_def by auto
    next
      case (insert m M)
      have "set (map f (inv set (insert m M)) st θ) =
            insert (f m stp θ) (set (map f (inv set M) st θ))"
        by (simp add: insert.hyps(1) inv_set_fset subst_apply_strand_def)
      thus ?case using f insert.IH by auto
    qed
  }
  thus "?A" "?B" by auto
qed

lemma strand_ground_subst_vars_subset:
  assumes "ground (subst_range θ)" shows "varsst (S st θ)  varsst S"
proof (induction S)
  case (Cons x S)
  have "varsstp (x stp θ)  varsstp x" using ground_subst_fv_subset[OF assms] 
  proof (cases x)
    case (Inequality X F)
    let  = "rm_vars (set X) θ"
    have "fvpairs (F pairs )  fvpairs F"
    proof (induction F)
      case (Cons f F)
      obtain t t' where f: "f = (t,t')" by (metis surj_pair)
      hence "fvpairs (f#F pairs ) = fv (t  )  fv (t'  )  fvpairs (F pairs )"
            "fvpairs (f#F) = fv t  fv t'  fvpairs F"
        by (auto simp add: subst_apply_pairs_def)
      thus ?case
        using ground_subst_fv_subset[OF ground_subset[OF rm_vars_img_subset assms, of "set X"]]
              Cons.IH
        by (metis (no_types, lifting) Un_mono)
    qed (simp add: subst_apply_pairs_def)
    moreover have
        "varsstp (x stp θ) = fvpairs (F pairs rm_vars (set X) θ)  set X"
        "varsstp x = fvpairs F  set X"
      using Inequality
      by (auto simp add: subst_apply_pairs_def)
    ultimately show ?thesis by auto
  qed auto
  thus ?case using Cons.IH by auto
qed (simp add: subst_apply_strand_def)

lemma ik_union_subset: "(P ` ikst S)  (x  (set S). (P ` trmsstp x))"
by (induct S rule: ikst.induct) auto

lemma ik_snd_empty[simp]: "ikst (map Send X) = {}"
by (induct "map Send X" arbitrary: X rule: ikst.induct) auto

lemma ik_snd_empty'[simp]: "ikst [Send t] = {}" by simp

lemma ik_append[iff]: "ikst (S@S') = ikst S  ikst S'" by (induct S rule: ikst.induct) auto

lemma ik_cons: "ikst (x#S) = ikst [x]  ikst S" using ik_append[of "[x]" S] by simp

lemma assignment_rhs_append[iff]: "assignment_rhsst (S@S') = assignment_rhsst S  assignment_rhsst S'"
by (induct S rule: assignment_rhsst.induct) auto

lemma eqs_rcv_map_empty: "assignment_rhsst (map Receive M) = {}"
by auto

lemma ik_rcv_map: assumes "t  set L" shows "t  ikst (map Receive L)"
proof -
  { fix L L' 
    have "t  ikst [Receive t]" by auto
    hence "t  ikst (map Receive L@Receive t#map Receive L')" using ik_append by auto
    hence "t  ikst (map Receive (L@t#L'))" by auto
  }
  thus ?thesis using assms split_list_last by force 
qed

lemma ik_subst: "ikst (S st δ) = ikst S set δ"
by (induct rule: ikst_induct) auto

lemma ik_rcv_map': assumes "t  ikst (map Receive L)" shows "t  set L"
using assms by force

lemma ik_append_subset[simp]: "ikst S  ikst (S@S')" "ikst S'  ikst (S@S')"
by (induct S rule: ikst.induct) auto

lemma assignment_rhs_append_subset[simp]:
  "assignment_rhsst S  assignment_rhsst (S@S')"
  "assignment_rhsst S'  assignment_rhsst (S@S')"
by (induct S rule: assignment_rhsst.induct) auto

lemma trmsst_cons: "trmsst (x#S) = trmsstp x  trmsst S" by simp

lemma trm_strand_subst_cong:
  "t  trmsst S  t  δ  trmsst (S st δ)
     (X F. Inequality X F  set S  t  rm_vars (set X) δ  trmsst (S st δ))"
    (is "t  trmsst S  ?P t δ S")
  "t  trmsst (S st δ)  (t'. t = t'  δ  t'  trmsst S)
     (X F. Inequality X F  set S  (t'  trmspairs F. t = t'  rm_vars (set X) δ))"
    (is "t  trmsst (S st δ)  ?Q t δ S")
proof -
  show "t  trmsst S  ?P t δ S"
  proof (induction S)
    case (Cons x S) show ?case
    proof (cases "t  trmsst S")
      case True
      hence "?P t δ S" using Cons by simp
      thus ?thesis
        by (cases x)
           (metis (no_types, lifting) Un_iff list.set_intros(2) strand_subst_hom(2) trmsst_cons)+
    next
      case False
      hence "t  trmsstp x" using Cons.prems by auto
      thus ?thesis
      proof (induction x)
        case (Inequality X F)
        hence "t  rm_vars (set X) δ  trmsstp (Inequality X F stp δ)"
          by (induct F) (auto simp add: subst_apply_pairs_def subst_apply_strand_step_def)
        thus ?case by fastforce
      qed (auto simp add: subst_apply_strand_step_def)
    qed
  qed simp

  show "t  trmsst (S st δ)  ?Q t δ S"
  proof (induction S)
    case (Cons x S) show ?case
    proof (cases "t  trmsst (S st δ)")
      case True
      hence "?Q t δ S" using Cons by simp
      thus ?thesis by (cases x) force+
    next
      case False
      hence "t  trmsstp (x stp δ)" using Cons.prems by auto
      thus ?thesis
      proof (induction x)
        case (Inequality X F)
        hence "t  trmsstp (Inequality X F) set rm_vars (set X) δ"
          by (induct F) (force simp add: subst_apply_pairs_def)+
        thus ?case by fastforce
      qed (auto simp add: subst_apply_strand_step_def)
    qed
  qed simp
qed


subsection ‹Lemmata: Free Variables of Strands›
lemma fv_trm_snd_rcv[simp]: "fvset (trmsstp (Send t)) = fv t" "fvset (trmsstp (Receive t)) = fv t"
by simp_all

lemma in_strand_fv_subset: "x  set S  varsstp x  varsst S" by fastforce
lemma in_strand_fv_subset_snd: "Send t  set S  fv t  (set (map fvsnd S))" by auto
lemma in_strand_fv_subset_rcv: "Receive t  set S  fv t  (set (map fvrcv S))" by auto

lemma fvsndE:
  assumes "v  (set (map fvsnd S))"
  obtains t where "send⟨tst  set S" "v  fv t"
proof -
  have "t. send⟨tst  set S  v  fv t"
    by (metis (no_types, lifting) assms UN_E empty_iff set_map strand_step.case_eq_if
              fvsnd_def strand_step.collapse(1))
  thus ?thesis by (metis that)
qed

lemma fvrcvE:
  assumes "v  (set (map fvrcv S))"
  obtains t where "receive⟨tst  set S" "v  fv t"
proof -
  have "t. receive⟨tst  set S  v  fv t"
    by (metis (no_types, lifting) assms UN_E empty_iff set_map strand_step.case_eq_if
              fvrcv_def strand_step.collapse(2))
  thus ?thesis by (metis that)
qed

lemma varsstpI[intro]: "x  fvstp s  x  varsstp s"
by (induct s rule: fvstp.induct) auto

lemma varsstI[intro]: "x  fvst S  x  varsst S" using varsstpI by fastforce

lemma fvst_subset_varsst[simp]: "fvst S  varsst S" using varsstI by force

lemma varsst_is_fvst_bvarsst: "varsst S = fvst S  bvarsst S"
proof (induction S)
  case (Cons x S) thus ?case
  proof (induction x)
    case (Inequality X F) thus ?case by (induct F) auto
  qed auto
qed simp

lemma fvstp_is_subterm_trmsstp: "x  fvstp a  Var x  subtermsset (trmsstp a)" 
using var_is_subterm by (cases a) force+

lemma fvst_is_subterm_trmsst: "x  fvst A  Var x  subtermsset (trmsst A)"
proof (induction A)
  case (Cons a A) thus ?case using fvstp_is_subterm_trmsstp by (cases "x  fvst A") auto
qed simp

lemma vars_st_snd_map: "varsst (map Send X) = fv (Fun f X)" by auto

lemma vars_st_rcv_map: "varsst (map Receive X) = fv (Fun f X)" by auto

lemma vars_snd_rcv_union:
  "varsstp x = fvsnd x  fvrcv x  fveq assign x  fveq check x  fvineq x  set (bvarsstp x)"
proof (cases x)
  case (Equality ac t t') thus ?thesis by (cases ac) auto
qed auto

lemma fv_snd_rcv_union:
  "fvstp x = fvsnd x  fvrcv x  fveq assign x  fveq check x  fvineq x"
proof (cases x)
  case (Equality ac t t') thus ?thesis by (cases ac) auto
qed auto

lemma fv_snd_rcv_empty[simp]: "fvsnd x = {}  fvrcv x = {}" by (cases x) simp_all

lemma vars_snd_rcv_strand[iff]:
  "varsst (S::('a,'b) strand) =
    ((set (map fvsnd S)))  ((set (map fvrcv S)))  ((set (map (fveq assign) S)))
     ((set (map (fveq check) S)))  ((set (map fvineq S)))  bvarsst S"
unfolding bvarsst_def
proof (induction S)
  case (Cons x S)
  have "s V. varsstp (s::('a,'b) strand_step)  V = 
                fvsnd s  fvrcv s  fveq assign s  fveq check s  fvineq s  set (bvarsstp s)  V"
    by (metis vars_snd_rcv_union)
  thus ?case using Cons.IH by (auto simp add: sup_assoc sup_left_commute)
qed simp

lemma fv_snd_rcv_strand[iff]:
  "fvst (S::('a,'b) strand) =
    ((set (map fvsnd S)))  ((set (map fvrcv S)))  ((set (map (fveq assign) S)))
     ((set (map (fveq check) S)))  ((set (map fvineq S)))"
unfolding bvarsst_def
proof (induction S)
  case (Cons x S)
  have "s V. fvstp (s::('a,'b) strand_step)  V = 
                fvsnd s  fvrcv s  fveq assign s  fveq check s  fvineq s  V"
    by (metis fv_snd_rcv_union)
  thus ?case using Cons.IH by (auto simp add: sup_assoc sup_left_commute)
qed simp

lemma vars_snd_rcv_strand2[iff]:
  "wfrestrictedvarsst (S::('a,'b) strand) =
    ((set (map fvsnd S)))  ((set (map fvrcv S)))  ((set (map (fveq assign) S)))"
by (induct S) (auto simp add: split: strand_step.split poscheckvariant.split)

lemma fv_snd_rcv_strand_subset[simp]:
  "(set (map fvsnd S))  fvst S" "(set (map fvrcv S))  fvst S"
  "(set (map (fveq ac) S))  fvst S" "(set (map fvineq S))  fvst S"
  "wfvarsoccsst S  fvst S"
proof -
  show "(set (map fvsnd S))  fvst S" "(set (map fvrcv S))  fvst S" "(set (map fvineq S))  fvst S"
    using fv_snd_rcv_strand[of S] by auto
  
  show "(set (map (fveq ac) S))  fvst S"
    by (induct S) (auto split: strand_step.split poscheckvariant.split)

  show "wfvarsoccsst S  fvst S"
    by (induct S) (auto split: strand_step.split poscheckvariant.split)
qed

lemma vars_snd_rcv_strand_subset2[simp]:
  "(set (map fvsnd S))  wfrestrictedvarsst S" "(set (map fvrcv S))  wfrestrictedvarsst S"
  "(set (map (fveq assign) S))  wfrestrictedvarsst S" "wfvarsoccsst S  wfrestrictedvarsst S"
by (induction S) (auto split: strand_step.split poscheckvariant.split)

lemma wfrestrictedvarsst_subset_varsst: "wfrestrictedvarsst S  varsst S"
by (induction S) (auto split: strand_step.split poscheckvariant.split)

lemma subst_sends_strand_step_fv_to_img: "fvstp (x stp δ)  fvstp x  range_vars δ" 
using subst_sends_fv_to_img[of _ δ]
proof (cases x)
  case (Inequality X F)
  let  = "rm_vars (set X) δ"
  have "fvpairs (F pairs )  fvpairs F  range_vars "
  proof (induction F)
    case (Cons f F) thus ?case
      using subst_sends_fv_to_img[of _ ]
      by (auto simp add: subst_apply_pairs_def)
  qed (auto simp add: subst_apply_pairs_def)
  hence "fvpairs (F pairs )  fvpairs F  range_vars δ"
    using rm_vars_img_subset[of "set X" δ] fv_set_mono
    unfolding range_vars_alt_def by blast+
  thus ?thesis using Inequality by (auto simp add: subst_apply_strand_step_def)
qed (auto simp add: subst_apply_strand_step_def)

lemma subst_sends_strand_fv_to_img: "fvst (S st δ)  fvst S  range_vars δ" 
proof (induction S)
  case (Cons x S)
  have *: "fvst (x#S st δ) = fvstp (x stp δ)  fvst (S st δ)"
          "fvst (x#S)  range_vars δ = fvstp x  fvst S  range_vars δ"
    by auto
  thus ?case using Cons.IH subst_sends_strand_step_fv_to_img[of x δ] by auto
qed simp

lemma ineq_apply_subst:
  assumes "subst_domain δ  set X = {}"
  shows "(Inequality X F) stp δ = Inequality X (F pairs δ)"
using rm_vars_apply'[OF assms] by (simp add: subst_apply_strand_step_def)

lemma fv_strand_step_subst:
  assumes "P = fvstp  P = fvrcv  P = fvsnd  P = fveq ac  P = fvineq"
  and "set (bvarsstp x)  (subst_domain δ  range_vars δ) = {}"
  shows "fvset (δ ` (P x)) = P (x stp δ)"
proof (cases x)
  case (Send t)
  hence "varsstp x = fv t" "fvsnd x = fv t" by auto
  thus ?thesis using assms Send subst_apply_fv_unfold[of _ δ] by auto
next
  case (Receive t)
  hence "varsstp x = fv t" "fvrcv x = fv t" by auto
  thus ?thesis using assms Receive subst_apply_fv_unfold[of _ δ] by auto
next
  case (Equality ac' t t') show ?thesis
  proof (cases "ac = ac'")
    case True
    hence "varsstp x = fv t  fv t'" "fveq ac x = fv t  fv t'"
      using Equality
      by auto
    thus ?thesis
      using assms Equality subst_apply_fv_unfold[of _ δ] True
      by auto
  next
    case False
    hence "varsstp x = fv t  fv t'" "fveq ac x = {}"
      using Equality
      by auto
    thus ?thesis
      using assms Equality subst_apply_fv_unfold[of _ δ] False
      by auto
  qed
next
  case (Inequality X F)
  hence 1: "set X  (subst_domain δ  range_vars δ) = {}"
           "x stp δ = Inequality X (F pairs δ)"
           "rm_vars (set X) δ = δ"
    using assms ineq_apply_subst[of δ X F] rm_vars_apply'[of δ "set X"]
    unfolding range_vars_alt_def by force+

  have 2: "fvineq x = fvpairs F - set X" using Inequality by auto
  hence "fvset (δ ` fvineq x) = fvset (δ ` fvpairs F) - set X"
    using fvset_subst_img_eq[OF 1(1), of "fvpairs F"] by simp
  hence 3: "fvset (δ ` fvineq x) = fvpairs (F pairs δ) - set X" by (metis fvpairs_step_subst)
  
  have 4: "fvineq (x stp δ) = fvpairs (F pairs δ) - set X" using 1(2) by auto

  show ?thesis
    using assms(1) Inequality subst_apply_fv_unfold[of _ δ] 1(2) 2 3 4
    unfolding fveq_def fvrcv_def fvsnd_def
    by (metis (no_types) Sup_empty image_empty fvpairs.simps fvset.simps
              fvstp.simps(4) strand_step.simps(20))
qed

lemma fv_strand_subst:
  assumes "P = fvstp  P = fvrcv  P = fvsnd  P = fveq ac  P = fvineq"
  and "bvarsst S  (subst_domain δ  range_vars δ) = {}"
  shows "fvset (δ ` ((set (map P S)))) = (set (map P (S st δ)))"
using assms(2)
proof (induction S)
  case (Cons x S)
  hence *: "bvarsst S  (subst_domain δ  range_vars δ) = {}"
           "set (bvarsstp x)  (subst_domain δ  range_vars δ) = {}"
    unfolding bvarsst_def by force+
  hence **: "fvset (δ ` P x) = P (x stp δ)" using fv_strand_step_subst[OF assms(1), of x δ] by auto
  have "fvset (δ ` ((set (map P (x#S))))) = fvset (δ ` P x)  ((set (map P ((S st δ)))))"
    using Cons unfolding range_vars_alt_def bvarsst_def by force
  hence "fvset (δ ` ((set (map P (x#S))))) = P (x stp δ)  fvset (δ ` ((set (map P S))))"
    using ** by simp
  thus ?case using Cons.IH[OF *(1)] unfolding bvarsst_def by simp
qed simp

lemma fv_strand_subst2:
  assumes "bvarsst S  (subst_domain δ  range_vars δ) = {}"
  shows "fvset (δ ` (wfrestrictedvarsst S)) = wfrestrictedvarsst (S st δ)"
by (metis (no_types, lifting) assms fvset.simps vars_snd_rcv_strand2 fv_strand_subst UN_Un image_Un)

lemma fv_strand_subst':
  assumes "bvarsst S  (subst_domain δ  range_vars δ) = {}"
  shows "fvset (δ ` (fvst S)) = fvst (S st δ)"
by (metis assms fv_strand_subst fvst_def)

lemma fv_trmspairs_is_fvpairs:
  "fvset (trmspairs F) = fvpairs F"
by auto

lemma fvpairs_in_fv_trmspairs: "x  fvpairs F  x  fvset (trmspairs F)"
using fv_trmspairs_is_fvpairs[of F] by blast

lemma trmsst_append: "trmsst (A@B) = trmsst A  trmsst B"
by auto

lemma trmspairs_subst: "trmspairs (a pairs θ) = trmspairs a set θ"
by (auto simp add: subst_apply_pairs_def)

lemma trmspairs_fv_subst_subset:
  "t  trmspairs F  fv (t  θ)  fvpairs (F pairs θ)"
by (force simp add: subst_apply_pairs_def)

lemma trmspairs_fv_subst_subset':
  fixes t::"('a,'b) term" and θ::"('a,'b) subst"
  assumes "t  subtermsset (trmspairs F)"
  shows "fv (t  θ)  fvpairs (F pairs θ)"
proof -
  { fix x assume "x  fv t"
    hence "x  fvpairs F"
      using fv_subset[OF assms] fv_subterms_set[of "trmspairs F"] fv_trmspairs_is_fvpairs[of F]
      by blast
    hence "fv (θ x)  fvpairs (F pairs θ)" using fvpairs_subst_fv_subset by fast
  } thus ?thesis by (meson fv_subst_obtain_var subset_iff) 
qed

lemma trmspairs_funs_term_cases:
  assumes "t  trmspairs (F pairs θ)" "f  funs_term t"
  shows "(u  trmspairs F. f  funs_term u)  (x  fvpairs F. f  funs_term (θ x))"
using assms(1)
proof (induction F)
  case (Cons g F)
  obtain s u where g: "g = (s,u)" by (metis surj_pair)
  show ?case
  proof (cases "t  trmspairs (F pairs θ)")
    case False
    thus ?thesis
      using assms(2) Cons.prems g funs_term_subst[of _ θ]
      by (auto simp add: subst_apply_pairs_def)
  qed (use Cons.IH in fastforce)
qed simp

lemma trmstp_subst: 
  assumes "subst_domain θ  set (bvarsstp a) = {}"
  shows "trmsstp (a stp θ) = trmsstp a set θ"
proof -
  have "rm_vars (set (bvarsstp a)) θ = θ" using assms by force
  thus ?thesis
    using assms
    by (auto simp add: subst_apply_pairs_def subst_apply_strand_step_def
             split: strand_step.splits)
qed

lemma trmsst_subst:
  assumes "subst_domain θ  bvarsst A = {}"
  shows "trmsst (A st θ) = trmsst A set θ"
using assms
proof (induction A)
  case (Cons a A)
  have 1: "subst_domain θ  bvarsst A = {}" "subst_domain θ  set (bvarsstp a) = {}"
    using Cons.prems by auto
  hence IH: "trmsst A set θ = trmsst (A st θ)" using Cons.IH by simp
  
  have "trmsst (a#A) = trmsstp a  trmsst A" by auto
  hence 2: "trmsst (a#A) set θ = (trmsstp a set θ)  (trmsst A set θ)" by (metis image_Un)

  have "trmsst (a#A st θ) = (trmsstp (a stp θ))  trmsst (A st θ)"
    by (auto simp add: subst_apply_strand_def)
  hence 3: "trmsst (a#A st θ) = (trmsstp a set θ)  trmsst (A st θ)"
    using trmstp_subst[OF 1(2)] by auto
  
  show ?case using IH 2 3 by metis
qed (simp add: subst_apply_strand_def)

lemma strand_map_set_subst:
  assumes δ: "bvarsst S  (subst_domain δ  range_vars δ) = {}"
  shows "(set (map trmsstp (S st δ))) = ((set (map trmsstp S))) set δ"
using assms
proof (induction S)
  case (Cons x S)
  hence "bvarsst [x]  subst_domain δ = {}" "bvarsst S  (subst_domain δ  range_vars δ) = {}"
    unfolding bvarsst_def by force+
  hence *: "subst_domain δ  set (bvarsstp x) = {}"
           "(set (map trmsstp (S st δ))) = (set (map trmsstp S)) set δ"
    using Cons.IH(1) bvarsst_singleton[of x] by auto
  hence "trmsstp (x stp δ) = (trmsstp x) set δ"
  proof (cases x)
    case (Inequality X F)
    thus ?thesis
      using rm_vars_apply'[of δ "set X"] * 
      by (metis (no_types, lifting) image_cong trmstp_subst)
  qed simp_all
  thus ?case using * subst_all_insert by auto
qed simp

lemma subst_apply_fv_subset_strand_trm:
  assumes P: "P = fvstp  P = fvrcv  P = fvsnd  P = fveq ac  P = fvineq"
  and fv_sub: "fv t  (set (map P S))  V"
  and δ: "bvarsst S  (subst_domain δ  range_vars δ) = {}"
  shows "fv (t  δ)  (set (map P (S st δ)))  fvset (δ ` V)"
using fv_strand_subst[OF P δ] subst_apply_fv_subset[OF fv_sub, of δ] by force

lemma subst_apply_fv_subset_strand_trm2:
  assumes fv_sub: "fv t  wfrestrictedvarsst S  V"
  and δ: "bvarsst S  (subst_domain δ  range_vars δ) = {}"
  shows "fv (t  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
using fv_strand_subst2[OF δ] subst_apply_fv_subset[OF fv_sub, of δ] by force

lemma subst_apply_fv_subset_strand:
  assumes P: "P = fvstp  P = fvrcv  P = fvsnd  P = fveq ac  P = fvineq"
  and P_subset: "P x  (set (map P S))  V"
  and δ: "bvarsst S  (subst_domain δ  range_vars δ) = {}"
         "set (bvarsstp x)  (subst_domain δ  range_vars δ) = {}"
  shows "P (x stp δ)  (set (map P (S st δ)))  fvset (δ ` V)"
proof (cases x)
  case (Send t)
  hence *: "fvstp x = fv t" "fvstp (x stp δ) = fv (t  δ)"
           "fvrcv x = {}" "fvrcv (x stp δ) = {}"
           "fvsnd x = fv t" "fvsnd (x stp δ) = fv (t  δ)"
           "fveq ac x = {}" "fveq ac (x stp δ) = {}"
           "fvineq x = {}" "fvineq (x stp δ) = {}"
    by auto
  hence **: "(P x = fv t  P (x stp δ) = fv (t  δ))  (P x = {}  P (x stp δ) = {})" by (metis P)
  moreover
  { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
  moreover
  { assume "P x = fv t" "P (x stp δ) = fv (t  δ)"
    hence "fv t  (set (map P S))  V" using P_subset by auto
    hence "fv (t  δ)  (set (map P (S st δ)))  fvset (δ ` V)"
      unfolding varsst_def using P subst_apply_fv_subset_strand_trm assms by blast
    hence ?thesis using P (x stp δ) = fv (t  δ) by force
  }
  ultimately show ?thesis by metis
next
  case (Receive t)
  hence *: "fvstp x = fv t" "fvstp (x stp δ) = fv (t  δ)"
           "fvrcv x = fv t" "fvrcv (x stp δ) = fv (t  δ)"
           "fvsnd x = {}" "fvsnd (x stp δ) = {}"
           "fveq ac x = {}" "fveq ac (x stp δ) = {}"
           "fvineq x = {}" "fvineq (x stp δ) = {}"
    by auto
  hence **: "(P x = fv t  P (x stp δ) = fv (t  δ))  (P x = {}  P (x stp δ) = {})" by (metis P)
  moreover
  { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
  moreover
  { assume "P x = fv t" "P (x stp δ) = fv (t  δ)"
    hence "fv t  (set (map P S))  V" using P_subset by auto
    hence "fv (t  δ)  (set (map P (S st δ)))  fvset (δ ` V)"
      unfolding varsst_def using P subst_apply_fv_subset_strand_trm assms by blast
    hence ?thesis using P (x stp δ) = fv (t  δ) by blast
  }
  ultimately show ?thesis by metis
next
  case (Equality ac' t t') show ?thesis
  proof (cases "ac' = ac")
    case True
    hence *: "fvstp x = fv t  fv t'" "fvstp (x stp δ) = fv (t  δ)  fv (t'  δ)"
             "fvrcv x = {}" "fvrcv (x stp δ) = {}"
             "fvsnd x = {}" "fvsnd (x stp δ) = {}"
             "fveq ac x = fv t  fv t'" "fveq ac (x stp δ) = fv (t  δ)  fv (t'  δ)"
             "fvineq x = {}" "fvineq (x stp δ) = {}"
      using Equality by auto
    hence **: "(P x = fv t  fv t'  P (x stp δ) = fv (t  δ)  fv (t'  δ))
               (P x = {}  P (x stp δ) = {})"
      by (metis P)
    moreover
    { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
    moreover
    { assume "P x = fv t  fv t'" "P (x stp δ) = fv (t  δ)  fv (t'  δ)"
      hence "fv t  (set (map P S))  V" "fv t'  (set (map P S))  V" using P_subset by auto
      hence "fv (t  δ)  (set (map P (S st δ)))  fvset (δ ` V)"
            "fv (t'  δ)  (set (map P (S st δ)))  fvset (δ ` V)"
        unfolding varsst_def using P subst_apply_fv_subset_strand_trm assms by metis+
      hence ?thesis using P (x stp δ) = fv (t  δ)  fv (t'  δ) by blast
    }
    ultimately show ?thesis by metis
  next
    case False
    hence *: "fvstp x = fv t  fv t'" "fvstp (x stp δ) = fv (t  δ)  fv (t'  δ)"
             "fvrcv x = {}" "fvrcv (x stp δ) = {}"
             "fvsnd x = {}" "fvsnd (x stp δ) = {}"
             "fveq ac x = {}" "fveq ac (x stp δ) = {}"
             "fvineq x = {}" "fvineq (x stp δ) = {}"
      using Equality by auto
    hence **: "(P x = fv t  fv t'  P (x stp δ) = fv (t  δ)  fv (t'  δ))
               (P x = {}  P (x stp δ) = {})"
      by (metis P)
    moreover
    { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
    moreover
    { assume "P x = fv t  fv t'" "P (x stp δ) = fv (t  δ)  fv (t'  δ)"
      hence "fv t  (set (map P S))  V" "fv t'  (set (map P S))  V" using P_subset by auto
      hence "fv (t  δ)  (set (map P (S st δ)))  fvset (δ ` V)"
            "fv (t'  δ)  (set (map P (S st δ)))  fvset (δ ` V)"
        unfolding varsst_def using P subst_apply_fv_subset_strand_trm assms by metis+
      hence ?thesis using P (x stp δ) = fv (t  δ)  fv (t'  δ) by blast
    }
    ultimately show ?thesis by metis
  qed
next
  case (Inequality X F)
  hence *: "fvstp x = fvpairs F - set X" "fvstp (x stp δ) = fvpairs (F pairs δ) - set X"
           "fvrcv x = {}" "fvrcv (x stp δ) = {}"
           "fvsnd x = {}" "fvsnd (x stp δ) = {}"
           "fveq ac x = {}" "fveq ac (x stp δ) = {}"
           "fvineq x = fvpairs F - set X"
           "fvineq (x stp δ) = fvpairs (F pairs δ) - set X"
    using δ(2) ineq_apply_subst[of δ X F] by force+
  hence **: "(P x = fvpairs F - set X  P (x stp δ) = fvpairs (F pairs δ) - set X)
             (P x = {}  P (x stp δ) = {})"
    by (metis P)
  moreover
  { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
  moreover
  { assume "P x = fvpairs F - set X" "P (x stp δ) = fvpairs (F pairs δ) - set X"
    hence "fvpairs F - set X  (set (map P S))  V"
      using P_subset by auto
    hence "fvpairs (F pairs δ)  (set (map P (S st δ)))  fvset (δ ` (V  set X))"
    proof (induction F)
      case (Cons f G)
      hence IH: "fvpairs (G pairs δ)  (set (map P (S st δ)))  fvset (δ ` (V  set X))"
        by (metis (no_types, lifting) Diff_subset_conv UN_insert le_sup_iff
                  list.simps(15) fvpairs.simps)
      obtain t t' where f: "f = (t,t')" by (metis surj_pair)
      hence "fv t  (set (map P S))  (V  set X)" "fv t'  (set (map P S))  (V  set X)"
        using Cons.prems by auto
      hence "fv (t  δ)  (set (map P (S st δ)))  fvset (δ ` (V  set X))"
            "fv (t'  δ)  (set (map P (S st δ)))  fvset (δ ` (V  set X))"
        using subst_apply_fv_subset_strand_trm[OF P _ assms(3)]
        by blast+
      thus ?case using f IH by (auto simp add: subst_apply_pairs_def)
    qed (simp add: subst_apply_pairs_def)
    moreover have "fvset (δ ` set X) = set X" using assms(4) Inequality by force
    ultimately have "fvpairs (F pairs δ) - set X  (set (map P (S st δ)))  fvset (δ ` V)"
      by auto
    hence ?thesis using P (x stp δ) = fvpairs (F pairs δ) - set X by blast
  }
  ultimately show ?thesis by metis
qed

lemma subst_apply_fv_subset_strand2:
  assumes P: "P = fvstp  P = fvrcv  P = fvsnd  P = fveq ac  P = fvineq  P = fv_req ac"
  and P_subset: "P x  wfrestrictedvarsst S  V"
  and δ: "bvarsst S  (subst_domain δ  range_vars δ) = {}"
         "set (bvarsstp x)  (subst_domain δ  range_vars δ) = {}"
  shows "P (x stp δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
proof (cases x)
  case (Send t)
  hence *: "fvstp x = fv t" "fvstp (x stp δ) = fv (t  δ)"
           "fvrcv x = {}" "fvrcv (x stp δ) = {}"
           "fvsnd x = fv t" "fvsnd (x stp δ) = fv (t  δ)"
           "fveq ac x = {}" "fveq ac (x stp δ) = {}"
           "fvineq x = {}" "fvineq (x stp δ) = {}"
           "fv_req ac x = {}" "fv_req ac (x stp δ) = {}"
    by auto
  hence **: "(P x = fv t  P (x stp δ) = fv (t  δ))  (P x = {}  P (x stp δ) = {})" by (metis P)
  moreover
  { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
  moreover
  { assume "P x = fv t" "P (x stp δ) = fv (t  δ)"
    hence "fv t  wfrestrictedvarsst S  V" using P_subset by auto
    hence "fv (t  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
      using P subst_apply_fv_subset_strand_trm2 assms by blast
    hence ?thesis using P (x stp δ) = fv (t  δ) by blast
  }
  ultimately show ?thesis by metis
next
  case (Receive t)
  hence *: "fvstp x = fv t" "fvstp (x stp δ) = fv (t  δ)"
           "fvrcv x = fv t" "fvrcv (x stp δ) = fv (t  δ)"
           "fvsnd x = {}" "fvsnd (x stp δ) = {}"
           "fveq ac x = {}" "fveq ac (x stp δ) = {}"
           "fvineq x = {}" "fvineq (x stp δ) = {}"
           "fv_req ac x = {}" "fv_req ac (x stp δ) = {}"
    by auto
  hence **: "(P x = fv t  P (x stp δ) = fv (t  δ))  (P x = {}  P (x stp δ) = {})" by (metis P)
  moreover
  { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
  moreover
  { assume "P x = fv t" "P (x stp δ) = fv (t  δ)"
    hence "fv t  wfrestrictedvarsst S  V" using P_subset by auto
    hence "fv (t  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
      using P subst_apply_fv_subset_strand_trm2 assms by blast
    hence ?thesis using P (x stp δ) = fv (t  δ) by blast
  }
  ultimately show ?thesis by metis
next
  case (Equality ac' t t') show ?thesis
  proof (cases "ac' = ac")
    case True
    hence *: "fvstp x = fv t  fv t'" "fvstp (x stp δ) = fv (t  δ)  fv (t'  δ)"
             "fvrcv x = {}" "fvrcv (x stp δ) = {}"
             "fvsnd x = {}" "fvsnd (x stp δ) = {}"
             "fveq ac x = fv t  fv t'" "fveq ac (x stp δ) = fv (t  δ)  fv (t'  δ)"
             "fvineq x = {}" "fvineq (x stp δ) = {}"
             "fv_req ac x = fv t'" "fv_req ac (x stp δ) = fv (t'  δ)"
      using Equality by auto
    hence **: "(P x = fv t  fv t'  P (x stp δ) = fv (t  δ)  fv (t'  δ))
               (P x = {}  P (x stp δ) = {})
               (P x = fv t'  P (x stp δ) = fv (t'  δ))"
      by (metis P)
    moreover
    { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
    moreover
    { assume "P x = fv t  fv t'" "P (x stp δ) = fv (t  δ)  fv (t'  δ)"
      hence "fv t  wfrestrictedvarsst S  V" "fv t'  wfrestrictedvarsst S  V" using P_subset by auto
      hence "fv (t  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
            "fv (t'  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
        using P subst_apply_fv_subset_strand_trm2 assms by blast+
      hence ?thesis using P (x stp δ) = fv (t  δ)  fv (t'  δ) by blast
    }
    moreover
    { assume "P x = fv t'" "P (x stp δ) = fv (t'  δ)"
      hence "fv t'  wfrestrictedvarsst S  V" using P_subset by auto
      hence "fv (t'  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
        using P subst_apply_fv_subset_strand_trm2 assms by blast+
      hence ?thesis using P (x stp δ) = fv (t'  δ) by blast
    }
    ultimately show ?thesis by metis
  next
    case False
    hence *: "fvstp x = fv t  fv t'" "fvstp (x stp δ) = fv (t  δ)  fv (t'  δ)"
             "fvrcv x = {}" "fvrcv (x stp δ) = {}"
             "fvsnd x = {}" "fvsnd (x stp δ) = {}"
             "fveq ac x = {}" "fveq ac (x stp δ) = {}"
             "fvineq x = {}" "fvineq (x stp δ) = {}"
             "fv_req ac x = {}" "fv_req ac (x stp δ) = {}"
      using Equality by auto
    hence **: "(P x = fv t  fv t'  P (x stp δ) = fv (t  δ)  fv (t'  δ))
               (P x = {}  P (x stp δ) = {})
               (P x = fv t'  P (x stp δ) = fv (t'  δ))"
      by (metis P)
    moreover
    { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
    moreover
    { assume "P x = fv t  fv t'" "P (x stp δ) = fv (t  δ)  fv (t'  δ)"
      hence "fv t  wfrestrictedvarsst S  V" "fv t'  wfrestrictedvarsst S  V"
        using P_subset by auto
      hence "fv (t  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
            "fv (t'  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
        using P subst_apply_fv_subset_strand_trm2 assms by blast+
      hence ?thesis using P (x stp δ) = fv (t  δ)  fv (t'  δ) by blast
    }
    moreover
    { assume "P x = fv t'" "P (x stp δ) = fv (t'  δ)"
      hence "fv t'  wfrestrictedvarsst S  V" using P_subset by auto
      hence "fv (t'  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
        using P subst_apply_fv_subset_strand_trm2 assms by blast+
      hence ?thesis using P (x stp δ) = fv (t'  δ) by blast
    }
    ultimately show ?thesis by metis
  qed
next
  case (Inequality X F)
  hence *: "fvstp x = fvpairs F - set X" "fvstp (x stp δ) = fvpairs (F pairs δ) - set X"
           "fvrcv x = {}" "fvrcv (x stp δ) = {}"
           "fvsnd x = {}" "fvsnd (x stp δ) = {}"
           "fveq ac x = {}" "fveq ac (x stp δ) = {}"
           "fvineq x = fvpairs F - set X" "fvineq (x stp δ) = fvpairs (F pairs δ) - set X"
           "fv_req ac x = {}" "fv_req ac (x stp δ) = {}"
    using δ(2) ineq_apply_subst[of δ X F] by force+
  hence **: "(P x = fvpairs F - set X  P (x stp δ) = fvpairs (F pairs δ) - set X)
             (P x = {}  P (x stp δ) = {})"
    by (metis P)
  moreover
  { assume "P x = {}" "P (x stp δ) = {}" hence ?thesis by simp }
  moreover
  { assume "P x = fvpairs F - set X" "P (x stp δ) = fvpairs (F pairs δ) - set X"
    hence "fvpairs F - set X  wfrestrictedvarsst S  V" using P_subset by auto
    hence "fvpairs (F pairs δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` (V  set X))"
    proof (induction F)
      case (Cons f G)
      hence IH: "fvpairs (G pairs δ) wfrestrictedvarsst (S st δ)  fvset (δ ` (V  set X))"
        by (metis (no_types, lifting) Diff_subset_conv UN_insert le_sup_iff
                  list.simps(15) fvpairs.simps)
      obtain t t' where f: "f = (t,t')" by (metis surj_pair)
      hence "fv t  wfrestrictedvarsst S  (V  set X)" "fv t'  wfrestrictedvarsst S  (V  set X)"
        using Cons.prems by auto
      hence "fv (t  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` (V  set X))"
            "fv (t'  δ)  wfrestrictedvarsst (S st δ)  fvset (δ ` (V  set X))"
        using subst_apply_fv_subset_strand_trm2[OF _ assms(3)] P
        by blast+
      thus ?case using f IH by (auto simp add: subst_apply_pairs_def)
    qed (simp add: subst_apply_pairs_def)
    moreover have "fvset (δ ` set X) = set X" using assms(4) Inequality by force
    ultimately have "fvpairs (F pairs δ) - set X  wfrestrictedvarsst (S st δ)  fvset (δ ` V)"
      by fastforce
    hence ?thesis using P (x stp δ) = fvpairs (F pairs δ) - set X by blast
  }
  ultimately show ?thesis by metis
qed

lemma strand_subst_fv_bounded_if_img_bounded:
  assumes "range_vars δ  fvst S"
  shows "fvst (S st δ)  fvst S"
using subst_sends_strand_fv_to_img[of S δ] assms by blast

lemma strand_fv_subst_subset_if_subst_elim:
  assumes "subst_elim δ v" and "v  fvst S  bvarsst S  (subst_domain δ  range_vars δ) = {}"
  shows "v  fvst (S st δ)"
proof (cases "v  fvst S")
  case True thus ?thesis
  proof (induction S)
    case (Cons x S)
    have *: "v  fvstp (x stp δ)"
    using assms(1)
    proof (cases x)
      case (Inequality X F)
      hence "subst_elim (rm_vars (set X) δ) v  v  set X" using assms(1) by blast
      moreover have "fvstp (Inequality X F stp δ) = fvpairs (F pairs rm_vars (set X) δ) - set X"
        using Inequality by auto
      ultimately have "v  fvstp (Inequality X F stp δ)"
        by (induct F) (auto simp add: subst_elim_def subst_apply_pairs_def)
      thus ?thesis using Inequality by simp
    qed (simp_all add: subst_elim_def)
    moreover have "v  fvst (S st δ)" using Cons.IH
    proof (cases "v  fvst S")
      case False
      moreover have "v  range_vars δ"
        by (simp add: subst_elimD''[OF assms(1)] range_vars_alt_def) 
      ultimately show ?thesis by (meson UnE subsetCE subst_sends_strand_fv_to_img)
    qed simp
    ultimately show ?case by auto
  qed simp
next
  case False
  thus ?thesis
    using assms fv_strand_subst'
    unfolding subst_elim_def
    by (metis (mono_tags, hide_lams) fvset.simps imageE mem_simps(8) subst_apply_term.simps(1))
qed

lemma strand_fv_subst_subset_if_subst_elim':
  assumes "subst_elim δ v" "v  fvst S" "range_vars δ  fvst S"
  shows "fvst (S st δ)  fvst S"
using strand_fv_subst_subset_if_subst_elim[OF assms(1)] assms(2)
      strand_subst_fv_bounded_if_img_bounded[OF assms(3)]
by blast

lemma fv_ik_is_fv_rcv: "fvset (ikst S) = (set (map fvrcv S))"
by (induct S rule: ikst.induct) auto

lemma fv_ik_subset_fv_st[simp]: "fvset (ikst S)  wfrestrictedvarsst S"
by (induct S rule: ikst.induct) auto

lemma fv_assignment_rhs_subset_fv_st[simp]: "fvset (assignment_rhsst S)  wfrestrictedvarsst S"
by (induct S rule: assignment_rhsst.induct) force+

lemma fv_ik_subset_fv_st'[simp]: "fvset (ikst S)  fvst S"
by (induct S rule: ikst.induct) auto

lemma ikst_var_is_fv: "Var x  subtermsset (ikst A)  x  fvst A"
by (meson fv_ik_subset_fv_st'[of A] fv_subset_subterms subsetCE term.set_intros(3))

lemma fv_assignment_rhs_subset_fv_st'[simp]: "fvset (assignment_rhsst S)  fvst S"
by (induct S rule: assignment_rhsst.induct) auto

lemma ikst_assignment_rhsst_wfrestrictedvars_subset:
  "fvset (ikst A  assignment_rhsst A)  wfrestrictedvarsst A"
using fv_ik_subset_fv_st[of A] fv_assignment_rhs_subset_fv_st[of A]
by simp+

lemma strand_step_id_subst[iff]: "x stp Var = x" by (cases x) auto

lemma strand_id_subst[iff]: "S st Var = S" using strand_step_id_subst by (induct S) auto

lemma strand_subst_vars_union_bound[simp]: "varsst (S st δ)  varsst S  range_vars δ"
proof (induction S)
  case (Cons x S)
  moreover have "varsstp (x stp δ)  varsstp x  range_vars δ" using subst_sends_fv_to_img[of _ δ]
  proof (cases x)
    case (Inequality X F)
    define δ' where "δ'  rm_vars (set X) δ"
    have 0: "range_vars δ'  range_vars δ"
      using rm_vars_img[of "set X" δ]
      by (auto simp add: δ'_def subst_domain_def range_vars_alt_def)

    have "varsstp (x stp δ) = fvpairs (F pairs δ')  set X" "varsstp x = fvpairs F  set X"
      using Inequality by (auto simp add: δ'_def)
    moreover have "fvpairs (F pairs δ')  fvpairs F  range_vars δ"
    proof (induction F)
      case (Cons f G)
      obtain t t' where f: "f = (t,t')" by moura
      hence "fvpairs (f#G pairs δ') = fv (t  δ')  fv (t'  δ')  fvpairs (G pairs δ')"
            "fvpairs (f#G) = fv t  fv t'  fvpairs G"
        by (auto simp add: subst_apply_pairs_def)
      thus ?case
        using 0 Cons.IH subst_sends_fv_to_img[of t δ'] subst_sends_fv_to_img[of t' δ']
        unfolding f by auto
    qed (simp add: subst_apply_pairs_def)
    ultimately show ?thesis by auto
  qed auto
  ultimately show ?case by auto
qed simp

lemma strand_vars_split:
  "varsst (S@S') = varsst S  varsst S'"
  "wfrestrictedvarsst (S@S') = wfrestrictedvarsst S  wfrestrictedvarsst S'"
  "fvst (S@S') = fvst S  fvst S'"
by auto

lemma bvars_subst_ident: "bvarsst S = bvarsst (S st δ)"
unfolding bvarsst_def
by (induct S) (simp_all add: subst_apply_strand_step_def split: strand_step.splits)

lemma strand_subst_subst_idem:
  assumes "subst_idem δ" "subst_domain δ  range_vars δ  fvst S" "subst_domain θ  fvst S = {}"
          "range_vars δ  bvarsst S = {}" "range_vars θ  bvarsst S = {}"
  shows "(S st δ) st θ = (S st δ)"
  and   "(S st δ) st (θ s δ) = (S st δ)"
proof -
  from assms(2,3) have "fvst (S st δ)  subst_domain θ = {}"
    using subst_sends_strand_fv_to_img[of S δ] by blast
  thus "(S st δ) st θ = (S st δ)" by blast
  thus "(S st δ) st (θ s δ) = (S st δ)"
    by (metis assms(1,4,5) bvars_subst_ident strand_subst_comp subst_idem_def)
qed

lemma strand_subst_img_bound:
  assumes "subst_domain δ  range_vars δ  fvst S"
    and "(subst_domain δ  range_vars δ)  bvarsst S = {}"
  shows "range_vars δ  fvst (S st δ)"
proof -
  have "subst_domain δ  (set (map fvstp S))" by (metis (no_types) fvst_def Un_subset_iff assms(1))
  thus ?thesis
    unfolding range_vars_alt_def fvst_def
    by (metis subst_range.simps fv_set_mono fv_strand_subst Int_commute assms(2) image_Un
              le_iff_sup)
qed

lemma strand_subst_img_bound':
  assumes "subst_domain δ  range_vars δ  varsst S"
    and "(subst_domain δ  range_vars δ)  bvarsst S = {}"
  shows "range_vars δ  varsst (S st δ)"
proof -
  have "(subst_domain δ  fvset (δ ` subst_domain δ))  varsst S =
        subst_domain δ  fvset (δ ` subst_domain δ)"
    using assms(1) by (metis inf.absorb_iff1 range_vars_alt_def subst_range.simps)
  hence "range_vars δ  fvst (S st δ)"
    using vars_snd_rcv_strand fv_snd_rcv_strand assms(2) strand_subst_img_bound
    unfolding range_vars_alt_def
    by (metis (no_types) inf_le2 inf_sup_distrib1 subst_range.simps sup_bot.right_neutral)
  thus "range_vars δ  varsst (S st δ)"
    by (metis fv_snd_rcv_strand le_supI1 vars_snd_rcv_strand)
qed

lemma strand_subst_all_fv_subset:
  assumes "fv t  fvst S" "(subst_domain δ  range_vars δ)  bvarsst S = {}"
  shows "fv (t  δ)  fvst (S st δ)"
using assms by (metis fv_strand_subst' Int_commute subst_apply_fv_subset)

lemma strand_subst_not_dom_fixed:
  assumes "v  fvst S" and "v  subst_domain δ"
  shows "v  fvst (S st δ)"
using assms
proof (induction S)
  case (Cons x S')
  have 1: "X. v  subst_domain (rm_vars (set X) δ)"
    using Cons.prems(2) rm_vars_dom_subset by force
  
  show ?case
  proof (cases "v  fvst S'")
    case True thus ?thesis using Cons.IH[OF _ Cons.prems(2)] by auto
  next
    case False
    hence 2: "v  fvstp x" using Cons.prems(1) by simp
    hence "v  fvstp (x stp δ)" using Cons.prems(2) subst_not_dom_fixed
    proof (cases x)
      case (Inequality X F)
      hence "v  fvpairs F - set X" using 2 by simp
      hence "v  fvpairs (F pairs rm_vars (set X) δ)"
        using subst_not_dom_fixed[OF _ 1]
        by (induct F) (auto simp add: subst_apply_pairs_def)
      thus ?thesis using Inequality 2 by auto
    qed (force simp add: subst_domain_def)+
    thus ?thesis by auto
  qed
qed simp

lemma strand_vars_unfold: "v  varsst S  S' x S''. S = S'@x#S''  v  varsstp x"
proof (induction S)
  case (Cons x S) thus ?case
  proof (cases "v  varsstp x")
    case True thus ?thesis by blast
  next
    case False
    hence "v  varsst S" using Cons.prems by auto
    thus ?thesis using Cons.IH by (metis append_Cons)
  qed
qed simp

lemma strand_fv_unfold: "v  fvst S  S' x S''. S = S'@x#S''  v  fvstp x"
proof (induction S)
  case (Cons x S) thus ?case
  proof (cases "v  fvstp x")
    case True thus ?thesis by blast
  next
    case False
    hence "v  fvst S" using Cons.prems by auto
    thus ?thesis using Cons.IH by (metis append_Cons)
  qed
qed simp

lemma subterm_if_in_strand_ik:
  "t  ikst S  t'. Receive t'  set S  t  t'"
by (induct S rule: ikst_induct) auto

lemma fv_subset_if_in_strand_ik:
  "t  ikst S  fv t  (set (map fvrcv S))"
proof -
  assume "t  ikst S"
  then obtain t' where "Receive t'  set S" "t  t'" by (metis subterm_if_in_strand_ik)
  hence "fv t  fv t'" by (simp add: subtermeq_vars_subset)
  thus ?thesis using in_strand_fv_subset_rcv[OF ‹Receive t'  set S] by auto
qed

lemma fv_subset_if_in_strand_ik':
  "t  ikst S  fv t  fvst S"
using fv_subset_if_in_strand_ik[of t S] fv_snd_rcv_strand_subset(2)[of S] by blast

lemma vars_subset_if_in_strand_ik2:
  "t  ikst S  fv t  wfrestrictedvarsst S"
using fv_subset_if_in_strand_ik[of t S] vars_snd_rcv_strand_subset2(2)[of S] by blast


subsection ‹Lemmata: Simple Strands›
lemma simple_Cons[dest]: "simple (s#S)  simple S"
unfolding simple_def by auto

lemma simple_split[dest]:
  assumes "simple (S@S')"
  shows "simple S" "simple S'"
using assms unfolding simple_def by auto

lemma simple_append[intro]: "simple S; simple S'  simple (S@S')"
unfolding simple_def by auto

lemma simple_append_sym[sym]: "simple (S@S')  simple (S'@S)" by auto

lemma not_simple_if_snd_fun: "(S' S'' f X. S = S'@Send (Fun f X)#S'')  ¬simple S"
unfolding simple_def by auto

lemma not_list_all_elim: "¬list_all P A  B x C. A = B@x#C  ¬P x  list_all P B"
proof (induction A rule: List.rev_induct)
  case (snoc a A)
  show ?case
  proof (cases "list_all P A")
    case True
    thus ?thesis using snoc.prems by auto
  next
    case False
    then obtain B x C where "A = B@x#C" "¬P x" "list_all P B" using snoc.IH[OF False] by auto
    thus ?thesis by auto
  qed
qed simp

lemma not_simplestp_elim:
  assumes "¬simplestp x"
  shows "(f T. x = Send (Fun f T))  
         (a t t'. x = Equality a t t') 
         (X F. x = Inequality X F  ¬(. ineq_model  X F))"
using assms by (cases x) (fastforce elim: simplestp.elims)+

lemma not_simple_elim:
  assumes "¬simple S"
  shows "(A B f T. S = A@Send (Fun f T)#B  simple A)  
         (A B a t t'. S = A@Equality a t t'#B  simple A) 
         (A B X F. S = A@Inequality X F#B  ¬(. ineq_model  X F))"
by (metis assms not_list_all_elim not_simplestp_elim simple_def)

lemma simple_fun_prefix_unique:
  assumes "A = S@Send (Fun f X)#S'" "simple S"
  shows "T g Y T'. A = T@Send (Fun g Y)#T'  simple T  S = T  f = g  X = Y  S' = T'"
proof -
  { fix T g Y T' assume *: "A = T@Send (Fun g Y)#T'" "simple T"
    { assume "length S < length T" hence False using assms *
        by (metis id_take_nth_drop not_simple_if_snd_fun nth_append nth_append_length)
    }
    moreover
    { assume "length S > length T" hence False using assms *
        by (metis id_take_nth_drop not_simple_if_snd_fun nth_append nth_append_length)
    }
    ultimately have "S = T" using assms * by (meson List.append_eq_append_conv linorder_neqE_nat)
  }
  thus ?thesis using assms(1) by blast
qed

lemma simple_snd_is_var: "Send t  set S; simple S  v. t = Var v"
unfolding simple_def
by (metis list_all_append list_all_simps(1) simplestp.elims(2) split_list_first
          strand_step.distinct(1) strand_step.distinct(5) strand_step.inject(1)) 


subsection ‹Lemmata: Strand Measure›
lemma measurest_wellfounded: "wf measurest" unfolding measurest_def by simp

lemma strand_size_append[iff]: "sizest (S@S') = sizest S + sizest S'"
by (induct S) (auto simp add: sizest_def)

lemma strand_size_map_fun_lt[simp]:
  "sizest (map Send X) < size (Fun f X)"
  "sizest (map Send X) < sizest [Send (Fun f X)]"
  "sizest (map Send X) < sizest [Receive (Fun f X)]"
by (induct X) (auto simp add: sizest_def)

lemma strand_size_rm_fun_lt[simp]:
  "sizest (S@S') < sizest (S@Send (Fun f X)#S')"
  "sizest (S@S') < sizest (S@Receive (Fun f X)#S')"
by (induct S) (auto simp add: sizest_def)

lemma strand_fv_card_map_fun_eq:
  "card (fvst (S@Send (Fun f X)#S')) = card (fvst (S@(map Send X)@S'))"
proof -
  have "fvst (S@Send (Fun f X)#S') = fvst (S@(map Send X)@S')" by auto
  thus ?thesis by simp
qed

lemma strand_fv_card_rm_fun_le[simp]: "card (fvst (S@S'))  card (fvst (S@Send (Fun f X)#S'))"
by (force intro: card_mono)

lemma strand_fv_card_rm_eq_le[simp]: "card (fvst (S@S'))  card (fvst (S@Equality a t t'#S'))"
by (force intro: card_mono)


subsection ‹Lemmata: Well-formed Strands›
lemma wf_prefix[dest]: "wfst V (S@S')  wfst V S"
by (induct S rule: wfst.induct) auto

lemma wf_vars_mono[simp]: "wfst V S  wfst (V  W) S"
proof (induction S arbitrary: V)
  case (Cons x S) thus ?case
  proof (cases x)
    case (Send t)
    hence "wfst (V  fv t  W) S" using Cons.prems(1) Cons.IH by simp
    thus ?thesis using Send by (simp add: sup_commute sup_left_commute)
  next
    case (Equality a t t')
    show ?thesis
    proof (cases a)
      case Assign
      hence "wfst (V  fv t  W) S" "fv t'  V  W" using Equality Cons.prems(1) Cons.IH by auto
      thus ?thesis using Equality Assign by (simp add: sup_commute sup_left_commute)
    next
      case Check thus ?thesis using Equality Cons by auto
    qed
  qed auto
qed simp

lemma wfstI[intro]: "wfrestrictedvarsst S  V  wfst V S"
proof (induction S)
  case (Cons x S) thus ?case
  proof (cases x)
    case (Send t)
    hence "wfst V S" "V  fv t = V" using Cons by auto
    thus ?thesis using Send by simp
  next
    case (Equality a t t')
    show ?thesis
    proof (cases a)
      case Assign
      hence "wfst V S" "fv t'  V" using Equality Cons by auto
      thus ?thesis using wf_vars_mono Equality Assign by simp
    next
      case Check thus ?thesis using Equality Cons by auto
    qed
  qed simp_all
qed simp

lemma wfstI'[intro]: "(fvrcv ` set S)  (fv_req assign ` set S)  V  wfst V S"
proof (induction S)
  case (Cons x S) thus ?case
  proof (cases x)
    case (Equality a t t') thus ?thesis using Cons by (cases a) auto
  qed simp_all
qed simp

lemma wf_append_exec: "wfst V (S@S')  wfst (V  wfvarsoccsst S) S'"
proof (induction S arbitrary: V)
  case (Cons x S V) thus ?case
  proof (cases x)
    case (Send t)
    hence "wfst (V  fv t  wfvarsoccsst S) S'" using Cons.prems Cons.IH by simp
    thus ?thesis using Send by (auto simp add: sup_assoc)
  next
    case (Equality a t t') show ?thesis
    proof (cases a)
      case Assign
      hence "wfst (V  fv t  wfvarsoccsst S) S'" using Equality Cons.prems Cons.IH by auto
      thus ?thesis using Equality Assign by (auto simp add: sup_assoc)
    next
      case Check
      hence "wfst (V  wfvarsoccsst S) S'" using Equality Cons.prems Cons.IH by auto
      thus ?thesis using Equality Check by (auto simp add: sup_assoc)
    qed
  qed auto
qed simp

lemma wf_append_suffix:
  "wfst V S  wfrestrictedvarsst S'  wfrestrictedvarsst S  V  wfst V (S@S')"
proof (induction V S rule: wfst_induct)
  case (ConsSnd V t S)
  hence *: "wfst (V  fv t) S" by simp_all
  hence "wfrestrictedvarsst S'  wfrestrictedvarsst S  (V  fv t)"
    using ConsSnd.prems(2) by fastforce
  thus ?case using ConsSnd.IH * by simp
next
  case (ConsRcv V t S)
  hence *: "fv t  V" "wfst V S" by simp_all
  hence "wfrestrictedvarsst S'  wfrestrictedvarsst S  V"
    using ConsRcv.prems(2) by fastforce
  thus ?case using ConsRcv.IH * by simp
next
  case (ConsEq V t t' S)
  hence *: "fv t'  V" "wfst (V  fv t) S" by simp_all
  moreover have "varsstp (Equality Assign t t') = fv t  fv t'"
    by simp
  moreover have "wfrestrictedvarsst (Equality Assign t t'#S) = fv t  fv t'  wfrestrictedvarsst S"
    by auto
  ultimately have "wfrestrictedvarsst S'  wfrestrictedvarsst S  (V  fv t)"
    using ConsEq.prems(2) by blast
  thus ?case using ConsEq.IH * by simp
qed (simp_all add: wfstI)

lemma wf_append_suffix':
  assumes "wfst V S"
    and "(fvrcv ` set S')  (fv_req assign ` set S')  wfvarsoccsst S  V"
  shows "wfst V (S@S')"
using assms
proof (induction V S rule: wfst_induct)
  case (ConsSnd V t S)
  hence *: "wfst (V  fv t) S" by simp_all
  have "wfvarsoccsst (send⟨tst#S) = fv t  wfvarsoccsst S"
    unfolding wfvarsoccsst_def by simp
  hence "(aset S'. fvrcv a)  (aset S'. fv_req assign a)  wfvarsoccsst S  (V  fv t)"
    using ConsSnd.prems(2) unfolding wfvarsoccsst_def by auto
  thus ?case using ConsSnd.IH[OF *] by auto
next
  case (ConsEq V t t' S)
  hence *: "fv t'  V" "wfst (V  fv t) S" by simp_all
  have "wfvarsoccsst (assign: t  t'st#S) = fv t  wfvarsoccsst S"
    unfolding wfvarsoccsst_def by simp
  hence "(aset S'. fvrcv a)  (aset S'. fv_req assign a)  wfvarsoccsst S  (V  fv t)"
    using ConsEq.prems(2) unfolding wfvarsoccsst_def by auto
  thus ?case using ConsEq.IH[OF *(2)] *(1) by auto
qed (auto simp add: wfstI')

lemma wf_send_compose: "wfst V (S@(map Send X)@S') = wfst V (S@Send (Fun f X)#S')"
proof (induction S arbitrary: V)
  case Nil thus ?case 
  proof (induction X arbitrary: V)
    case (Cons y Y) thus ?case by (simp add: sup_assoc)
  qed simp
next
  case (Cons s S) thus ?case
  proof (cases s)
    case (Equality ac t t') thus ?thesis using Cons by (cases ac) auto
  qed auto
qed

lemma wf_snd_append[iff]: "wfst V (S@[Send t]) = wfst V S"
by (induct S rule: wfst.induct) simp_all

lemma wf_snd_append': "wfst V S  wfst V (Send t#S)"
by simp

lemma wf_rcv_append[dest]: "wfst V (S@Receive t#S')  wfst V (S@S')"
by (induct S rule: wfst.induct) simp_all

lemma wf_rcv_append'[intro]:
  "wfst V (S@S'); fv t  wfrestrictedvarsst S  V  wfst V (S@Receive t#S')"
proof (induction S rule: wfst_induct)
  case (ConsRcv V t' S)
  hence "wfst V (S@S')" "fv t  wfrestrictedvarsst S  V"
    by auto+
  thus ?case using ConsRcv by auto
next
  case (ConsEq V t' t'' S)
  hence "fv t''  V" by simp
  moreover have
      "wfrestrictedvarsst (Equality Assign t' t''#S) = fv t'  fv t''  wfrestrictedvarsst S"
    by auto
  ultimately have "fv t  wfrestrictedvarsst S  (V  fv t')"
    using ConsEq.prems(2) by blast
  thus ?case using ConsEq by auto
qed auto

lemma wf_rcv_append''[intro]: "wfst V S; fv t  (set (map fvsnd S))  wfst V (S@[Receive t])"
by (induct S)
   (simp, metis vars_snd_rcv_strand_subset2(1) append_Nil2 le_supI1 order_trans wf_rcv_append')

lemma wf_rcv_append'''[intro]: "wfst V S; fv t  wfrestrictedvarsst S  V  wfst V (S@[Receive t])"
by (simp add: wf_rcv_append'[of _ _ "[]"])

lemma wf_eq_append[dest]: "wfst V (S@Equality a t t'#S')  fv t  wfrestrictedvarsst S  V  wfst V (S@S')"
proof (induction S rule: wfst_induct)
  case (Nil V)
  hence "wfst (V  fv t) S'" by (cases a) auto
  moreover have "V  fv t = V" using Nil by auto
  ultimately show ?case by simp
next
  case (ConsRcv V u S)
  hence "wfst V (S @ Equality a t t' # S')" "fv t  wfrestrictedvarsst S  V" "fv u  V"
    by fastforce+
  hence "wfst V (S@S')" using ConsRcv.IH by auto
  thus ?case using ‹fv u  V by simp
next
  case (ConsEq V u u' S)
  hence "wfst (V  fv u) (S@Equality a t t'#S')" "fv t  wfrestrictedvarsst S  (V  fv u)" "fv u'  V"
    by auto
  hence "wfst (V  fv u) (S@S')" using ConsEq.IH by auto
  thus ?case using ‹fv u'  V by simp
qed auto

lemma wf_eq_append'[intro]:
  "wfst V (S@S'); fv t'  wfrestrictedvarsst S  V  wfst V (S@Equality a t t'#S')"
proof (induction S rule: wfst_induct)
  case Nil thus ?case by (cases a) auto
next
  case (ConsEq V u u' S)
  hence "wfst (V  fv u) (S@S')" "fv t'  wfrestrictedvarsst S  V  fv u"
    by fastforce+
  thus ?case using ConsEq by auto
next
  case (ConsEq2 V u u' S)
  hence "wfst V (S@S')" by auto
  thus ?case using ConsEq2 by auto
next
  case (ConsRcv V u S)
  hence "wfst V (S@S')" "fv t'  wfrestrictedvarsst S  V"
    by fastforce+
  thus ?case using ConsRcv by auto
next
  case (ConsSnd V u S)
  hence "wfst (V  fv u) (S@S')" "fv t'  wfrestrictedvarsst S  (V  fv u)"
    by fastforce+
  thus ?case using ConsSnd by auto
qed auto

lemma wf_eq_append''[intro]:
  "wfst V (S@S'); fv t'  wfvarsoccsst S  V  wfst V (S@[Equality a t t']@S')"
proof (induction S rule: wfst_induct)
  case Nil thus ?case by (cases a) auto
next
  case (ConsEq V u u' S)
  hence "wfst (V  fv u) (S@S')" "fv t'  wfvarsoccsst S  V  fv u" by fastforce+
  thus ?case using ConsEq by auto
next
  case (ConsEq2 V u u' S)
  hence "wfst (V  fv u) (S@S')" "fv t'  wfvarsoccsst S  V  fv u" by fastforce+
  thus ?case using ConsEq2 by auto
next
  case (ConsRcv V u S)
  hence "wfst V (S@S')" "fv t'  wfvarsoccsst S  V" by fastforce+
  thus ?case using ConsRcv by auto
next
  case (ConsSnd V u S)
  hence "wfst (V  fv u) (S@S')" "fv t'  wfvarsoccsst S  (V  fv u)" by auto
  thus ?case using ConsSnd by auto
qed auto

lemma wf_eq_append'''[intro]:
  "wfst V S; fv t'  wfrestrictedvarsst S  V  wfst V (S@[Equality a t t'])"
by (simp add: wf_eq_append'[of _ _ "[]"])

lemma wf_eq_check_append[dest]: "wfst V (S@Equality Check t t'#S')  wfst V (S@S')"
by (induct S rule: wfst.induct) simp_all

lemma wf_eq_check_append'[intro]: "wfst V (S@S')  wfst V (S@Equality Check t t'#S')"
by (induct S rule: wfst.induct) auto

lemma wf_eq_check_append''[intro]: "wfst V S  wfst V (S@[Equality Check t t'])"
by (induct S rule: wfst.induct) auto

lemma wf_ineq_append[dest]: "wfst V (S@Inequality X F#S')  wfst V (S@S')"
by (induct S rule: wfst.induct) simp_all

lemma wf_ineq_append'[intro]: "wfst V (S@S')  wfst V (S@Inequality X F#S')"
by (induct S rule: wfst.induct) auto

lemma wf_ineq_append''[intro]: "wfst V S  wfst V (S@[Inequality X F])"
by (induct S rule: wfst.induct) auto

lemma wf_rcv_fv_single[elim]: "wfst V (Receive t#S')  fv t  V"
by simp

lemma wf_rcv_fv: "wfst V (S@Receive t#S')  fv t  wfvarsoccsst S  V"
by (induct S arbitrary: V) (auto split!: strand_step.split poscheckvariant.split)

lemma wf_eq_fv: "wfst V (S@Equality Assign t t'#S')  fv t'  wfvarsoccsst S  V"
by (induct S arbitrary: V) (auto split!: strand_step.split poscheckvariant.split)

lemma wf_simple_fv_occurrence:
  assumes "wfst {} S" "simple S" "v  wfrestrictedvarsst S"
  shows "Spre Ssuf. S = Spre@Send (Var v)#Ssuf  v  wfrestrictedvarsst Spre"
using assms
proof (induction S rule: List.rev_induct)
  case (snoc x S)
  from ‹wfst {} (S@[x]) have "wfst {} S" "wfst (wfrestrictedvarsst S) [x]"
    using wf_append_exec[THEN wf_vars_mono, of "{}" S "[x]" "wfrestrictedvarsst S - wfvarsoccsst S"]
          vars_snd_rcv_strand_subset2(4)[of S]
          Diff_partition[of "wfvarsoccsst S" "wfrestrictedvarsst S"]
    by auto
  from ‹simple (S@[x]) have "simple S" "simplestp x" unfolding simple_def by auto

  show ?case
  proof (cases "v  wfrestrictedvarsst S")
    case False
    show ?thesis
    proof (cases x)
      case (Receive t)
      hence "fv t  wfrestrictedvarsst S" using ‹wfst (wfrestrictedvarsst S) [x] by simp
      hence "v  wfrestrictedvarsst S"
        using v  wfrestrictedvarsst (S@[x]) x = Receive t
        by auto
      thus ?thesis using x = Receive t snoc.IH[OF ‹wfst {} S ‹simple S] by fastforce
    next
      case (Send t)
      hence "v  varsstp x" using v  wfrestrictedvarsst (S@[x]) False by auto
      from Send obtain w where "t = Var w" using ‹simplestp x by (cases t) simp_all
      hence "v = w" using x = Send t v  varsstp x by simp
      thus ?thesis using x = Send t v  wfrestrictedvarsst S t = Var w by auto
    next
      case (Equality ac t t') thus ?thesis using snoc.prems(2) unfolding simple_def by auto
    next
      case (Inequality t t') thus ?thesis using False snoc.prems(3) by auto
    qed
  qed (use snoc.IH[OF ‹wfst {} S ‹simple S] in fastforce)
qed simp

lemma Unifier_strand_fv_subset:
  assumes g_in_ik: "t  ikst S"
  and δ: "Unifier δ (Fun f X) t"
  and disj: "bvarsst S  (subst_domain δ  range_vars δ) = {}"
  shows "fv (Fun f X  δ)  (set (map fvrcv (S st δ)))"
by (metis (no_types) fv_subset_if_in_strand_ik[OF g_in_ik]
          disj δ fv_strand_subst subst_apply_fv_subset)

lemma wfst_induct'[consumes 1, case_names Nil ConsSnd ConsRcv ConsEq ConsEq2 ConsIneq]:
  fixes S::"('a,'b) strand"
  assumes "wfst V S"
          "P []"
          "t S. wfst V S; P S  P (S@[Send t])"
          "t S. wfst V S; P S; fv t  V  wfvarsoccsst S  P (S@[Receive t])"
          "t t' S. wfst V S; P S; fv t'  V  wfvarsoccsst S  P (S@[Equality Assign t t'])"
          "t t' S. wfst V S; P S  P (S@[Equality Check t t'])"
          "X F S. wfst V S; P S  P (S@[Inequality X F])"
  shows "P S"
using assms
proof (induction S rule: List.rev_induct)
  case (snoc x S)
  hence *: "wfst V S" "wfst (V  wfvarsoccsst S) [x]" by (metis wf_prefix, metis wf_append_exec)
  have IH: "P S" using snoc.IH[OF *(1)] snoc.prems by auto
  note ** = snoc.prems(3,4,5,6,7)[OF *(1) IH] *(2)
  show ?case using **(1,2,4,5,6)
  proof (cases x)
    case (Equality ac t t')
    then show ?thesis using **(3,4,6) by (cases ac) auto
  qed auto
qed simp

lemma wf_subst_apply:
  "wfst V S  wfst (fvset (δ ` V)) (S st δ)"
proof (induction S arbitrary: V rule: wfst_induct)
  case (ConsRcv V t S)
  hence "wfst V S" "fv t  V" by simp_all
  hence "wfst (fvset (δ ` V)) (S st δ)" "fv (t  δ)  fvset (δ ` V)"
    using ConsRcv.IH subst_apply_fv_subset by simp_all
  thus ?case by simp
next
  case (ConsSnd V t S)
  hence "wfst (V  fv t) S" by simp
  hence "wfst (fvset (δ ` (V  fv t))) (S st δ)" using ConsSnd.IH by metis
  hence "wfst (fvset (δ ` V)  fv (t  δ)) (S st δ)" using subst_apply_fv_union by metis
  thus ?case by simp
next
  case (ConsEq V t t' S)
  hence "wfst (V  fv t) S" "fv t'  V" by auto
  hence "wfst (fvset (δ ` (V  fv t))) (S st δ)" and *: "fv (t'  δ)  fvset (δ ` V)"
    using ConsEq.IH subst_apply_fv_subset by force+
  hence "wfst (fvset (δ ` V)  fv (t  δ)) (S st δ)" using subst_apply_fv_union by metis
  thus ?case using * by simp
qed simp_all

lemma wf_unify:
  assumes wf: "wfst V (S@Send (Fun f X)#S')"
  and g_in_ik: "t  ikst S"
  and δ: "Unifier δ (Fun f X) t"
  and disj: "bvarsst (S@Send (Fun f X)#S')  (subst_domain δ  range_vars δ) = {}"
  shows "wfst (fvset (δ ` V)) ((S@S') st δ)"
using assms
proof (induction S' arbitrary: V rule: List.rev_induct)
  case (snoc x S' V)
  have fun_fv_bound: "fv (Fun f X  δ)  (set (map fvrcv (S st δ)))"
    using snoc.prems(4) bvarsst_split Unifier_strand_fv_subset[OF g_in_ik δ] by auto
  hence "fv (Fun f X  δ)  fvset (ikst (S st δ))" using fv_ik_is_fv_rcv by metis
  hence "fv (Fun f X  δ)  wfrestrictedvarsst (S st δ)" using fv_ik_subset_fv_st[of "S st δ"] by blast
  hence *: "fv ((Fun f X)  δ)  wfrestrictedvarsst ((S@S') st δ)" by fastforce

  from snoc.prems(1) have "wfst V (S@Send (Fun f X)#S')"
    using wf_prefix[of V "S@Send (Fun f X)#S'" "[x]"] by simp
  hence **: "wfst (fvset (δ ` V)) ((S@S') st δ)"
    using snoc.IH[OF _ snoc.prems(2,3)] snoc.prems(4) by auto

  from snoc.prems(1) have ***: "wfst (V  wfvarsoccsst (S@Send (Fun f X)#S')) [x]"
    using wf_append_exec[of V "(S@Send (Fun f X)#S')" "[x]"] by simp

  from snoc.prems(4) have disj':
      "bvarsst (S@S')  (subst_domain δ  range_vars δ) = {}"
      "set (bvarsstp x)  (subst_domain δ  range_vars δ) = {}"
    by auto

  show ?case
  proof (cases x)
    case (Send t)
    thus ?thesis using wf_snd_append[of "fvset (δ ` V)" "(S@S') st δ"] ** by auto
  next
    case (Receive t)
    hence "fvstp x  V  wfvarsoccsst (S@Send (Fun f X)#S')" using *** by auto
    hence "fvstp x  V  wfrestrictedvarsst (S@Send (Fun f X)#S')"
      using vars_snd_rcv_strand_subset2(4)[of "S@Send (Fun f X)#S'"] by blast
    hence "fvstp x  V  fv (Fun f X)  wfrestrictedvarsst (S@S')" by auto
    hence "fvstp (x stp δ)  fvset (δ ` V)  fv ((Fun f X)  δ)  wfrestrictedvarsst ((S@S') st δ)"
      by (metis (no_types) inf_sup_aci(5) subst_apply_fv_subset_strand2 subst_apply_fv_union disj')
    hence "fvstp (x stp δ)  fvset (δ ` V)  wfrestrictedvarsst ((S@S') st δ)" using * by blast
    hence "fv (t  δ)  wfrestrictedvarsst ((S@S') st δ)  fvset (δ ` V) " using x = Receive t by auto
    hence "wfst (fvset (δ ` V)) (((S@S') st δ)@[Receive (t  δ)])"
      using wf_rcv_append'''[OF **, of "t  δ"] by metis
    thus ?thesis using x = Receive t by auto
  next
    case (Equality ac s s') show ?thesis
    proof (cases ac)
      case Assign
      hence "fv s'  V  wfvarsoccsst (S@Send (Fun f X)#S')" using Equality *** by auto
      hence "fv s'  V  wfrestrictedvarsst (S@Send (Fun f X)#S')"
        using vars_snd_rcv_strand_subset2(4)[of "S@Send (Fun f X)#S'"] by blast
      hence "fv s'  V  fv (Fun f X)  wfrestrictedvarsst (S@S')" by auto
      moreover have "fv s' = fv_req ac x" "fv (s'  δ) = fv_req ac (x stp δ)"
        using Equality by simp_all
      ultimately have "fv (s'  δ)  fvset (δ ` V)  fv (Fun f X  δ)  wfrestrictedvarsst ((S@S') st δ)"
        using subst_apply_fv_subset_strand2[of "fveq ac" ac x]
        by (metis disj'(1) subst_apply_fv_subset_strand_trm2 subst_apply_fv_union sup_commute)
      hence "fv (s'  δ)  fvset (δ ` V)  wfrestrictedvarsst ((S@S') st δ)" using * by blast
      hence "fv (s'  δ)  wfrestrictedvarsst ((S@S') st δ)  fvset (δ ` V)"
        using x = Equality ac s s' by auto
      hence "wfst (fvset (δ ` V)) (((S@S') st δ)@[Equality ac (s  δ) (s'  δ)])"
        using wf_eq_append'''[OF **] by metis
      thus ?thesis using x = Equality ac s s' by auto
    next
      case Check thus ?thesis using wf_eq_check_append''[OF **] Equality by simp
    qed
  next
    case (Inequality t t') thus ?thesis using wf_ineq_append''[OF **] by simp
  qed
qed (auto dest: wf_subst_apply)

lemma wf_equality:
  assumes wf: "wfst V (S@Equality ac t t'#S')"
  and δ: "mgu t t' = Some δ"
  and disj: "bvarsst (S@Equality ac t t'#S')  (subst_domain δ  range_vars δ) = {}"
  shows "wfst (fvset (δ ` V)) ((S@S') st δ)"
using assms
proof (induction S' arbitrary: V rule: List.rev_induct)
  case Nil thus ?case using wf_prefix[of V S "[Equality ac t t']"] wf_subst_apply[of V S δ] by auto
next
  case (snoc x S' V) show ?case
  proof (cases ac)
    case Assign
    hence "fv t'  V  wfvarsoccsst S"
      using wf_eq_fv[of V, of S t t' "S'@[x]"] snoc by auto
    hence "fv t'  V  wfrestrictedvarsst S"
      using vars_snd_rcv_strand_subset2(4)[of S] by blast
    hence "fv t'  V  wfrestrictedvarsst (S@S')" by force
    moreover have disj':
        "bvarsst (S@S')  (subst_domain δ  range_vars δ) = {}"
        "set (bvarsstp x)  (subst_domain δ  range_vars δ) = {}"
        "bvarsst (S@Equality ac t t'#S')  (subst_domain δ  range_vars δ) = {}"
      using snoc.prems(3) by auto
    ultimately have
        "fv (t'  δ)  fvset (δ ` V)  wfrestrictedvarsst ((S@S') st δ)"
      by (metis inf_sup_aci(5) subst_apply_fv_subset_strand_trm2)
    moreover have "fv (t  δ) = fv (t'  δ)"
      by (metis MGU_is_Unifier[OF mgu_gives_MGU[OF δ]])
    ultimately have *:
        "fv (t  δ)  fv (t'  δ)  fvset (δ ` V)  wfrestrictedvarsst ((S@S') st δ)"
      by simp
  
    from snoc.prems(1) have "wfst V (S@Equality ac t t'#S')"
      using wf_prefix[of V "S@Equality ac t t'#S'"] by simp
    hence **: "wfst (fvset (δ ` V)) ((S@S') st δ)" by (metis snoc.IH δ disj'(3))
  
    from snoc.prems(1) have ***: "wfst (V  wfvarsoccsst (S@Equality ac t t'#S')) [x]"
      using wf_append_exec[of V "(S@Equality ac t t'#S')" "[x]"] by simp
  
    show ?thesis
    proof (cases x)
      case (Send t)
      thus ?thesis using wf_snd_append[of "fvset (δ ` V)" "(S@S') st δ"] ** by auto
    next
      case (Receive s)
      hence "fvstp x  V  wfvarsoccsst (S@Equality ac t t'#S')" using *** by auto
      hence "fvstp x  V  wfrestrictedvarsst (S@Equality ac t t'#S')"
        using vars_snd_rcv_strand_subset2(4)[of "S@Equality ac t t'#S'"] by blast
      hence "fvstp x  V  fv t  fv t'  wfrestrictedvarsst (S@S')"
        by (cases ac) auto
      hence "fvstp (x stp δ)  fvset (δ ` V)  fv (t  δ)  fv (t'  δ)  wfrestrictedvarsst ((S@S') st δ)"
        using subst_apply_fv_subset_strand2[of fvstp]
        by (metis (no_types) inf_sup_aci(5) subst_apply_fv_union disj'(1,2))
      hence "fvstp (x stp δ)  fvset (δ ` V)  wfrestrictedvarsst ((S@S') st δ)"
        when "ac = Assign"
        using * that by blast
      hence "fv (s  δ)  wfrestrictedvarsst ((S@S') st δ)  (fvset (δ ` V))"
        when "ac = Assign"
        using x = Receive s that by auto
      hence "wfst (fvset (δ ` V)) (((S@S') st δ)@[Receive (s  δ)])"
        when "ac = Assign"
        using wf_rcv_append'''[OF **, of "s  δ"] that by metis
      thus ?thesis using x = Receive s Assign by auto
    next
      case (Equality ac' s s') show ?thesis
      proof (cases ac')
        case Assign
        hence "fv s'  V  wfvarsoccsst (S@Equality ac t t'#S')" using *** Equality by auto
        hence "fv s'  V  wfrestrictedvarsst (S@Equality ac t t'#S')"
          using vars_snd_rcv_strand_subset2(4)[of "S@Equality ac t t'#S'"] by blast
        hence "fv s'  V  fv t  fv t'  wfrestrictedvarsst (S@S')"
          by (cases ac) auto
        moreover have "fv s' = fv_req ac' x" "fv (s'  δ) = fv_req ac' (x stp δ)"
          using Equality by simp_all
        ultimately have
            "fv (s'  δ)  fvset (δ ` V)  fv (t  δ)  fv (t'  δ)  wfrestrictedvarsst ((S@S') st δ)"
          using subst_apply_fv_subset_strand2[of "fv_req ac'" ac' x]
          by (metis disj'(1) subst_apply_fv_subset_strand_trm2 subst_apply_fv_union sup_commute)
        hence "fv (s'  δ)  fvset (δ ` V)  wfrestrictedvarsst ((S@S') st δ)"
          using * ac = Assign› by blast
        hence ****:
            "fv (s'  δ)  wfrestrictedvarsst ((S@S') st δ)  fvset (δ ` V)"
          using x = Equality ac' s s' ac = Assign› by auto
        thus ?thesis
          using x = Equality ac' s s' ** **** wf_eq_append' ac = Assign›
          by (metis (no_types, lifting) append.assoc append_Nil2 strand_step.case(3)
                strand_subst_hom subst_apply_strand_step_def)
      next
        case Check thus ?thesis using wf_eq_check_append''[OF **] Equality by simp
      qed
    next
      case (Inequality s s') thus ?thesis using wf_ineq_append''[OF **] by simp
    qed
  qed (metis snoc.prems(1) wf_eq_check_append wf_subst_apply)
qed

lemma wf_rcv_prefix_ground:
  "wfst {} ((map Receive M)@S)  varsst (map Receive M) = {}"
by (induct M) auto

lemma simple_wfvarsoccsst_is_fvsnd:
  assumes "simple S"
  shows "wfvarsoccsst S = (set (map fvsnd S))"
using assms unfolding simple_def
proof (induction S)
  case (Cons x S) thus ?case by (cases x) auto
qed simp

lemma wfst_simple_induct[consumes 2, case_names Nil ConsSnd ConsRcv ConsIneq]:
  fixes S::"('a,'b) strand"
  assumes "wfst V S" "simple S"
          "P []"
          "v S. wfst V S; simple S; P S  P (S@[Send (Var v)])"
          "t S. wfst V S; simple S; P S; fv t  V  (set (map fvsnd S))  P (S@[Receive t])"
          "X F S. wfst V S; simple S; P S  P (S@[Inequality X F])"
  shows "P S"
using assms
proof (induction S rule: wfst_induct')
  case (ConsSnd t S)
  hence "P S" by auto
  obtain v where "t = Var v" using simple_snd_is_var[OF _ ‹simple (S@[Send t])] by auto
  thus ?case using ConsSnd.prems(3)[OF ‹wfst V S _ P S] ‹simple (S@[Send t]) by auto
next
  case (ConsRcv t S) thus ?case using simple_wfvarsoccsst_is_fvsnd[of "S@[Receive t]"] by auto
qed (auto simp add: simple_def)

lemma wf_trm_stp_dom_fv_disjoint:
  "wfconstr S θ; t  trmsst S  subst_domain θ  fv t = {}"
unfolding wfconstr_def by force

lemma wf_constr_bvars_disj: "wfconstr S θ  (subst_domain θ  range_vars θ)  bvarsst S = {}"
unfolding range_vars_alt_def wfconstr_def by fastforce

lemma wf_constr_bvars_disj':
  assumes "wfconstr S θ" "subst_domain δ  range_vars δ  fvst S"
  shows "(subst_domain δ  range_vars δ)  bvarsst S = {}" (is ?A)
  and "(subst_domain θ  range_vars θ)  bvarsst (S st δ) = {}" (is ?B)
proof -
  have "(subst_domain θ  range_vars θ)  bvarsst S = {}" "fvst S  bvarsst S = {}"
    using assms(1) unfolding range_vars_alt_def wfconstr_def by fastforce+
  thus ?A and ?B using assms(2) bvars_subst_ident[of S δ] by blast+
qed

lemma (in intruder_model) wf_simple_strand_first_Send_var_split:
  assumes "wfst {} S" "simple S" "v  wfrestrictedvarsst S. t   =  v"
  shows "v Spre Ssuf. S = Spre@Send (Var v)#Ssuf  t   =  v
                       ¬(w  wfrestrictedvarsst Spre. t   =  w)"
    (is "?P S")
using assms
proof (induction S rule: wfst_simple_induct)
  case (ConsSnd v S) show ?case
  proof (cases "w  wfrestrictedvarsst S. t   =  w")
    case True thus ?thesis using ConsSnd.IH by fastforce
  next
    case False thus ?thesis using ConsSnd.prems by auto
  qed
next
  case (ConsRcv t' S)
  have "fv t'  wfrestrictedvarsst S" using ConsRcv.hyps(3) vars_snd_rcv_strand_subset2(1) by force
  hence "v  wfrestrictedvarsst S. t   =  v"
    using ConsRcv.prems(1) by fastforce
  hence "?P S" by (metis ConsRcv.IH)
  thus ?case by fastforce 
next
  case (ConsIneq X F S)
  moreover have "wfrestrictedvarsst (S @ [Inequality X F]) = wfrestrictedvarsst S" by auto
  ultimately have "?P S" by blast
  thus ?case by fastforce
qed simp

lemma (in intruder_model) wf_strand_first_Send_var_split:
  assumes "wfst {} S" "v  wfrestrictedvarsst S. t     v"
  shows "Spre Ssuf. ¬(w  wfrestrictedvarsst Spre. t     w)
             ((t'. S = Spre@Send t'#Ssuf  t    t'  )
                (t' t''. S = Spre@Equality Assign t' t''#Ssuf  t    t'  ))"
    (is "Spre Ssuf. ?P Spre  ?Q S Spre Ssuf")
using assms
proof (induction S rule: wfst_induct')
  case (ConsSnd t' S) show ?case
  proof (cases "w  wfrestrictedvarsst S. t     w")
    case True
    then obtain Spre Ssuf where "?P Spre" "?Q S Spre Ssuf"
      using ConsSnd.IH by moura
    thus ?thesis by fastforce
  next
    case False
    then obtain v where v: "v  fv t'" "t     v"
      using ConsSnd.prems by auto
    hence "t    t'  "
      using subst_mono[of "Var v" t' ] vars_iff_subtermeq[of v t'] term.order_trans
      by auto 
    thus ?thesis using False v by auto
  qed
next
  case (ConsRcv t' S)
  have "fv t'  wfrestrictedvarsst S"
    using ConsRcv.hyps vars_snd_rcv_strand_subset2(4)[of S] by blast
  hence "v  wfrestrictedvarsst S. t     v"
    using ConsRcv.prems by fastforce
  then obtain Spre Ssuf where "?P Spre" "?Q S Spre Ssuf"
    using ConsRcv.IH by moura
  thus ?case by fastforce
next
  case (ConsEq s s' S)
  have *: "fv s'  wfrestrictedvarsst S"
    using ConsEq.hyps vars_snd_rcv_strand_subset2(4)[of S]
    by blast
  show ?case
  proof (cases "v  wfrestrictedvarsst S. t     v")
    case True
    then obtain Spre Ssuf where "?P Spre" "?Q S Spre Ssuf"
      using ConsEq.IH by moura
    thus ?thesis by fastforce
  next
    case False
    then obtain v where "v  fv s" "t     v" using ConsEq.prems * by auto
    hence "t    s  "
      using vars_iff_subtermeq[of v s] subst_mono[of "Var v" s ] term.order_trans
      by auto
    thus ?thesis using False by fastforce
  qed
next
  case (ConsEq2 s s' S)
  have "wfrestrictedvarsst (S@[Equality Check s s']) = wfrestrictedvarsst S" by auto
  hence "v  wfrestrictedvarsst S. t     v" using ConsEq2.prems by metis
  then obtain Spre Ssuf where "?P Spre" "?Q S Spre Ssuf"
    using ConsEq2.IH by moura
  thus ?case by fastforce
next
  case (ConsIneq X F S)
  hence "v  wfrestrictedvarsst S. t     v" by fastforce
  then obtain Spre Ssuf where "?P Spre" "?Q S Spre Ssuf"
    using ConsIneq.IH by moura
  thus ?case by fastforce
qed simp


subsection ‹Constraint Semantics›
context intruder_model
begin

subsubsection ‹Definitions›
text ‹The constraint semantics in which the intruder is limited to composition only›
fun strand_sem_c::"('fun,'var) terms  ('fun,'var) strand  ('fun,'var) subst  bool" ("_; _c")
where
  "M; []c = (λ. True)"
| "M; Send t#Sc = (λ. M c t    M; Sc )"
| "M; Receive t#Sc = (λ. insert (t  ) M; Sc )"
| "M; Equality _ t t'#Sc = (λ. t   = t'    M; Sc )"
| "M; Inequality X F#Sc = (λ. ineq_model  X F  M; Sc )"

definition constr_sem_c ("_ c _,_") where " c S,θ  (θ supports   {}; Sc )"
abbreviation constr_sem_c' ("_ c _" 90) where " c S   c S,Var"

text ‹The full constraint semantics›
fun strand_sem_d::"('fun,'var) terms  ('fun,'var) strand  ('fun,'var) subst  bool" ("_; _d")
where
  "M; []d = (λ. True)"
| "M; Send t#Sd = (λ. M  t    M; Sd )"
| "M; Receive t#Sd = (λ. insert (t  ) M; Sd )"
| "M; Equality _ t t'#Sd = (λ. t   = t'    M; Sd )"
| "M; Inequality X F#Sd = (λ. ineq_model  X F  M; Sd )"

definition constr_sem_d ("_  _,_") where "  S,θ  (θ supports   {}; Sd )"
abbreviation constr_sem_d' ("_  _" 90) where "  S    S,Var"

lemmas strand_sem_induct = strand_sem_c.induct[case_names Nil ConsSnd ConsRcv ConsEq ConsIneq]


subsubsection ‹Lemmata›
lemma strand_sem_d_if_c: " c S,θ    S,θ"
proof -
  assume *: " c S,θ"
  { fix M have "M; Sc   M; Sd "
    proof (induction S rule: strand_sem_induct)
      case (ConsSnd M t S)
      hence "M c t  " "M; Sd " by auto
      thus ?case using strand_sem_d.simps(2)[of M t S] by auto
    qed (auto simp add: ineq_model_def)
  }
  thus ?thesis using * by (simp add: constr_sem_c_def constr_sem_d_def)
qed

lemma strand_sem_mono_ik:
  "M  M'; M; Sc θ  M'; Sc θ" (is "?A'; ?A''  ?A")
  "M  M'; M; Sd θ  M'; Sd θ" (is "?B'; ?B''  ?B")
proof -
  show "?A'; ?A''  ?A"
  proof (induction M S arbitrary: M M' rule: strand_sem_induct)
    case (ConsRcv M t S)
    thus ?case using ConsRcv.IH[of "insert (t  θ) M" "insert (t  θ) M'"] by auto
  next
    case (ConsSnd M t S)
    hence "M c t  θ" "M'; Sc θ" by auto
    hence "M' c t  θ" using ideduct_synth_mono M  M' by metis
    thus ?case using M'; Sc θ by simp
  qed auto

  show "?B'; ?B''  ?B"
  proof (induction M S arbitrary: M M' rule: strand_sem_induct)
    case (ConsRcv M t S)
    thus ?case using ConsRcv.IH[of "insert (t  θ) M" "insert (t  θ) M'"] by auto
  next
    case (ConsSnd M t S)
    hence "M  t  θ" "M'; Sd θ" by auto
    hence "M'  t  θ" using ideduct_mono M  M' by metis
    thus ?case using M'; Sd θ by simp
  qed auto
qed

context
begin
private lemma strand_sem_split_left:
  "M; S@S'c θ  M; Sc θ"
  "M; S@S'd θ  M; Sd θ"
proof (induct S arbitrary: M)
  case (Cons x S)
  { case 1 thus ?case using Cons by (cases x) simp_all }
  { case 2 thus ?case using Cons by (cases x) simp_all }
qed simp_all

private lemma strand_sem_split_right:
  "M; S@S'c θ  M  (ikst S set θ); S'c θ"
  "M; S@S'd θ  M  (ikst S set θ); S'd θ"
proof (induction S arbitrary: M rule: ikst_induct)
  case (ConsRcv t S)
  { case 1 thus ?case using ConsRcv.IH[of "insert (t  θ) M"] by simp }
  { case 2 thus ?case using ConsRcv.IH[of "insert (t  θ) M"] by simp }
qed simp_all

lemmas strand_sem_split[dest] =
  strand_sem_split_left(1) strand_sem_split_right(1)
  strand_sem_split_left(2) strand_sem_split_right(2)
end

lemma strand_sem_Send_split[dest]:
  "M; map Send Tc θ; t  set T  M; [Send t]c θ" (is "?A'; ?A''  ?A")
  "M; map Send Td θ; t  set T  M; [Send t]d θ" (is "?B'; ?B''  ?B")
  "M; map Send T@Sc θ; t  set T  M; Send t#Sc θ" (is "?C'; ?C''  ?C")
  "M; map Send T@Sd θ; t  set T  M; Send t#Sd θ" (is "?D'; ?D''  ?D")
proof -
  show A: "?A'; ?A''  ?A" by (induct "map Send T" arbitrary: T rule: strand_sem_c.induct) auto
  show B: "?B'; ?B''  ?B" by (induct "map Send T" arbitrary: T rule: strand_sem_d.induct) auto
  show "?C'; ?C''  ?C" "?D'; ?D''  ?D"
    using list.set_map list.simps(8) set_empty ik_snd_empty sup_bot.right_neutral
    by (metis (no_types, lifting) A strand_sem_split(1,2) strand_sem_c.simps(2),
        metis (no_types, lifting) B strand_sem_split(3,4) strand_sem_d.simps(2))
qed

lemma strand_sem_Send_map:
  "(t. t  set T  M; [Send t]c )  M; map Send Tc "
  "(t. t  set T  M; [Send t]d )  M; map Send Td "
by (induct T) auto

lemma strand_sem_Receive_map: "M; map Receive Tc " "M; map Receive Td "
by (induct T arbitrary: M) auto

lemma strand_sem_append[intro]:
  "M; Sc θ; M  (ikst S set θ); S'c θ  M; S@S'c θ"
  "M; Sd θ; M  (ikst S set θ); S'd θ  M; S@S'd θ"
proof (induction S arbitrary: M)
  case (Cons x S) 
  { case 1 thus ?case using Cons by (cases x) auto }
  { case 2 thus ?case using Cons by (cases x) auto }
qed simp_all

lemma ineq_model_subst:
  fixes F::"(('a,'b) term × ('a,'b) term) list"
  assumes "(subst_domain δ  range_vars δ)  set X = {}"
    and "ineq_model (δ s θ) X F"
  shows "ineq_model θ X (F pairs δ)"
proof -
  { fix σ::"('a,'b) subst" and t t'
    assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
        and *: "list_ex (λf. fst f  (σ s (δ s θ))  snd f  (σ s (δ s θ))) F"
    obtain f where f: "f  set F" "fst f  σ s (δ s θ)  snd f  σ s (δ s θ)"
      using * by (induct F) auto
    have "σ s (δ s θ) = δ s (σ s θ)"
      by (metis (no_types, lifting) σ subst_compose_assoc assms(1) inf_sup_aci(1)
              subst_comp_eq_if_disjoint_vars sup_inf_absorb range_vars_alt_def) 
    hence "(fst f  δ)  σ s θ  (snd f  δ)  σ s θ" using f by auto
    moreover have "(fst f  δ, snd f  δ)  set (F pairs δ)"
      using f(1) by (auto simp add: subst_apply_pairs_def)
    ultimately have "list_ex (λf. fst f  (σ s θ)  snd f  (σ s θ)) (F pairs δ)"
      using f(1) Bex_set by fastforce
  }
  thus ?thesis using assms unfolding ineq_model_def by simp
qed

lemma ineq_model_subst':
  fixes F::"(('a,'b) term × ('a,'b) term) list"
  assumes "(subst_domain δ  range_vars δ)  set X = {}"
    and "ineq_model θ X (F pairs δ)"
  shows "ineq_model (δ s θ) X F"
proof -
  { fix σ::"('a,'b) subst" and t t'
    assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
        and *: "list_ex (λf. fst f  (σ s θ)  snd f  (σ s θ)) (F pairs δ)"
    obtain f where f: "f  set (F pairs δ)" "fst f  σ s θ  snd f  σ s θ"
      using * by (induct F) (auto simp add: subst_apply_pairs_def)
    then obtain g where g: "g  set F" "f = g p δ" by (auto simp add: subst_apply_pairs_def)
    have "σ s (δ s θ) = δ s (σ s θ)"
      by (metis (no_types, lifting) σ subst_compose_assoc assms(1) inf_sup_aci(1)
              subst_comp_eq_if_disjoint_vars sup_inf_absorb range_vars_alt_def) 
    hence "fst g  σ s (δ s θ)  snd g  σ s (δ s θ)"
      using f(2) g by (simp add: prod.case_eq_if)
    hence "list_ex (λf. fst f  (σ s (δ s θ))  snd f  (σ s (δ s θ))) F"
      using g Bex_set by fastforce
  }
  thus ?thesis using assms unfolding ineq_model_def by simp
qed

lemma ineq_model_ground_subst:
  fixes F::"(('a,'b) term × ('a,'b) term) list"
  assumes "fvpairs F - set X  subst_domain δ"
    and "ground (subst_range δ)"
    and "ineq_model δ X F"
  shows "ineq_model (δ s θ) X F"
proof -
  { fix σ::"('a,'b) subst" and t t'
    assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
        and *: "list_ex (λf. fst f  (σ s δ)  snd f  (σ s δ )) F"
    obtain f where f: "f  set F" "fst f  σ s δ  snd f  σ s δ"
      using * by (induct F) auto
    hence "fv (fst f)  fvpairs F" "fv (snd f)  fvpairs F" by auto
    hence "fv (fst f) - set X  subst_domain δ" "fv (snd f) - set X  subst_domain δ"
      using assms(1) by auto
    hence "fv (fst f  σ)  subst_domain δ" "fv (snd f  σ)  subst_domain δ"
      using σ by (simp_all add: range_vars_alt_def subst_fv_unfold_ground_img)
    hence "fv (fst f  σ s δ) = {}" "fv (snd f  σ s δ) = {}"
      using assms(2) by (simp_all add: subst_fv_dom_ground_if_ground_img)
    hence "fst f  σ s (δ s θ)  snd f  σ s (δ s θ)" using f(2) subst_ground_ident by fastforce 
    hence "list_ex (λf. fst f  (σ s (δ s θ))  snd f  (σ s (δ s θ))) F"
      using f(1) Bex_set by fastforce
  }
  thus ?thesis using assms unfolding ineq_model_def by simp
qed

context
begin
private lemma strand_sem_subst_c:
  assumes "(subst_domain δ  range_vars δ)  bvarsst S = {}"
  shows "M; Sc (δ s θ)  M; S st δc θ"
using assms
proof (induction S arbitrary: δ M rule: strand_sem_induct)
  case (ConsSnd M t S)
  hence "M; S st δc θ" "M c t  (δ s θ)" by auto
  hence "M c (t  δ)  θ"
    using subst_comp_all[of δ θ M] subst_subst_compose[of t δ θ] by simp
  thus ?case
    using M; S st δc θ
    unfolding subst_apply_strand_def
    by simp
next
  case (ConsRcv M t S)
  have *: "insert (t  δ s θ) M; Sc (δ s θ)" using ConsRcv.prems(1) by simp
  have "bvarsst (Receive t#S) = bvarsst S" by auto
  hence **: "(subst_domain δ  range_vars δ)  bvarsst S = {}" using ConsRcv.prems(2) by blast
  have "M; Receive (t  δ)#(S st δ)c θ"
    using ConsRcv.IH[OF * **] by (simp add: subst_all_insert)
  thus ?case by simp
next
  case (ConsIneq M X F S)
  hence *: "M; S st δc θ" and
        ***: "(subst_domain δ  range_vars δ)  set X = {}" 
    unfolding bvarsst_def ineq_model_def by auto
  have **: "ineq_model (δ s θ) X F"
    using ConsIneq by (auto simp add: subst_compose_assoc ineq_model_def)
  have "γ. subst_domain γ = set X  ground (subst_range γ)
           (subst_domain δ  range_vars δ)  (subst_domain γ  range_vars γ) = {}"
    using * ** *** unfolding range_vars_alt_def by auto
  hence "γ. subst_domain γ = set X  ground (subst_range γ)  γ s δ = δ s γ"
    by (metis subst_comp_eq_if_disjoint_vars)
  hence "ineq_model θ X (F pairs δ)"
    using ineq_model_subst[OF *** **]
    by blast
  moreover have "rm_vars (set X) δ = δ" using ConsIneq.prems(2) by force
  ultimately show ?case using * by auto
qed simp_all

private lemma strand_sem_subst_c':
  assumes "(subst_domain δ  range_vars δ)  bvarsst S = {}"
  shows "M; S st δc θ  M; Sc (δ s θ)"
using assms
proof (induction S arbitrary: δ M rule: strand_sem_induct)
  case (ConsSnd M t S)
  hence "M; [Send t] st δc θ" "M; S st δc θ" by auto
  hence "M; Sc (δ s θ)" using ConsSnd.IH[OF _] ConsSnd.prems(2) by auto
  moreover have "M; [Send t]c (δ s θ)"
  proof -
    have "M c t  δ  θ" using M; [Send t] st δc θ by auto
    hence "M c t  (δ s θ)" using subst_subst_compose by metis
    thus "M; [Send t]c (δ s θ)" by auto
  qed
  ultimately show ?case by auto
next
  case (ConsRcv M t S)
  hence "(insert (t  δ  θ) M); S st δc θ" by (simp add: subst_all_insert)
  thus ?case using ConsRcv.IH ConsRcv.prems(2) by auto
next
  case (ConsIneq M X F S)
  have δ: "rm_vars (set X) δ = δ" using ConsIneq.prems(2) by force
  hence *: "M; Sc (δ s θ)"
    and ***: "(subst_domain δ  range_vars δ)  set X = {}"
    using ConsIneq unfolding bvarsst_def ineq_model_def by auto
  have **: "ineq_model θ X (F pairs δ)"
    using ConsIneq.prems(1) δ by (auto simp add: subst_compose_assoc ineq_model_def)
  have "γ. subst_domain γ = set X  ground (subst_range γ)
           (subst_domain δ  range_vars δ)  (subst_domain γ  range_vars γ) = {}"
    using * ** *** unfolding range_vars_alt_def by auto
  hence "γ. subst_domain γ = set X  ground (subst_range γ)  γ s δ = δ s γ"
    by (metis subst_comp_eq_if_disjoint_vars)
  hence "ineq_model (δ s θ) X F"
    using ineq_model_subst'[OF *** **]
    by blast
  thus ?case using * by auto
next
  case ConsEq thus ?case unfolding bvarsst_def by auto
qed simp_all

private lemma strand_sem_subst_d:
  assumes "(subst_domain δ  range_vars δ)  bvarsst S = {}"
  shows "M; Sd (δ s θ)  M; S st δd θ"
using assms
proof (induction S arbitrary: δ M rule: strand_sem_induct)
  case (ConsSnd M t S)
  hence "M; S st δd θ" "M  t  (δ s θ)" by auto
  hence "M  (t  δ)  θ"
    using subst_comp_all[of δ θ M] subst_subst_compose[of t δ θ] by simp
  thus ?case using M; S st δd θ by simp
next
  case (ConsRcv M t S) 
  have *: "insert (t  δ s θ) M; Sd (δ s θ)" using ConsRcv.prems(1) by simp
  have "bvarsst (Receive t#S) = bvarsst S" by auto
  hence **: "(subst_domain δ  range_vars δ)  bvarsst S = {}" using ConsRcv.prems(2) by blast
  have "M; Receive (t  δ)#(S st δ)d θ"
    using ConsRcv.IH[OF * **] by (simp add: subst_all_insert)
  thus ?case by simp
next
  case (ConsIneq M X F S)
  hence *: "M; S st δd θ" and
        ***: "(subst_domain δ  range_vars δ)  set X = {}" 
    unfolding bvarsst_def ineq_model_def by auto
  have **: "ineq_model (δ s θ) X F"
    using ConsIneq by (auto simp add: subst_compose_assoc ineq_model_def)
  have "γ. subst_domain γ = set X  ground (subst_range γ)
           (subst_domain δ  range_vars δ)  (subst_domain γ  range_vars γ) = {}"
    using * ** *** unfolding range_vars_alt_def by auto
  hence "γ. subst_domain γ = set X  ground (subst_range γ)  γ s δ = δ s γ"
    by (metis subst_comp_eq_if_disjoint_vars)
  hence "ineq_model θ X (F pairs δ)"
    using ineq_model_subst[OF *** **]
    by blast
  moreover have "rm_vars (set X) δ = δ" using ConsIneq.prems(2) by force
  ultimately show ?case using * by auto
next
  case ConsEq thus ?case unfolding bvarsst_def by auto
qed simp_all

private lemma strand_sem_subst_d':
  assumes "(subst_domain δ  range_vars δ)  bvarsst S = {}"
  shows "M; S st δd θ  M; Sd (δ s θ)"
using assms
proof (induction S arbitrary: δ M rule: strand_sem_induct)
  case (ConsSnd M t S)
  hence "M; [Send t] st δd θ" "M; S st δd θ" by auto
  hence "M; Sd (δ s θ)" using ConsSnd.IH[OF _] ConsSnd.prems(2) by auto
  moreover have "M; [Send t]d (δ s θ)"
  proof -
    have "M  t  δ  θ" using M; [Send t] st δd θ by auto
    hence "M  t  (δ s θ)" using subst_subst_compose by metis
    thus "M; [Send t]d (δ s θ)" by auto
  qed
  ultimately show ?case by auto
next
  case (ConsRcv M t S)
  hence "insert (t  δ  θ) M; S st δd θ" by (simp add: subst_all_insert)
  thus ?case using ConsRcv.IH ConsRcv.prems(2) by auto
next
  case (ConsIneq M X F S)
  have δ: "rm_vars (set X) δ = δ" using ConsIneq.prems(2) by force
  hence *: "M; Sd (δ s θ)"
    and ***: "(subst_domain δ  range_vars δ)  set X = {}"
    using ConsIneq unfolding bvarsst_def ineq_model_def by auto
  have **: "ineq_model θ X (F pairs δ)"
    using ConsIneq.prems(1) δ by (auto simp add: subst_compose_assoc ineq_model_def)
  have "γ. subst_domain γ = set X  ground (subst_range γ)
           (subst_domain δ  range_vars δ)  (subst_domain γ  range_vars γ) = {}"
    using * ** *** unfolding range_vars_alt_def by auto
  hence "γ. subst_domain γ = set X  ground (subst_range γ)  γ s δ = δ s γ"
    by (metis subst_comp_eq_if_disjoint_vars)
  hence "ineq_model (δ s θ) X F"
    using ineq_model_subst'[OF *** **]
    by blast
  thus ?case using * by auto
next
  case ConsEq thus ?case unfolding bvarsst_def by auto
qed simp_all

lemmas strand_sem_subst =
  strand_sem_subst_c strand_sem_subst_c' strand_sem_subst_d strand_sem_subst_d'
end

lemma strand_sem_subst_subst_idem:
  assumes δ: "(subst_domain δ  range_vars δ)  bvarsst S = {}"
  shows "M; S st δc (δ s θ); subst_idem δ  M; Sc (δ s θ)"
using strand_sem_subst(2)[OF assms, of M "δ s θ"] subst_compose_assoc[of δ δ θ]
unfolding subst_idem_def by argo

lemma strand_sem_subst_comp:
  assumes "(subst_domain θ  range_vars θ)  bvarsst S = {}"
    and "M; Sc δ" "subst_domain θ  (varsst S  fvset M) = {}"
  shows "M; Sc (θ s δ)"
proof -
  from assms(3) have "subst_domain θ  varsst S = {}" "subst_domain θ  fvset M = {}" by auto
  hence "S st θ = S" "M set θ = M" using strand_substI set_subst_ident[of M θ] by (blast, blast)
  thus ?thesis using assms(2) by (auto simp add: strand_sem_subst(2)[OF assms(1)])
qed

lemma strand_sem_c_imp_ineqs_neq:
  assumes "M; Sc " "Inequality X [(t,t')]  set S"
  shows "t  t'  (δ. subst_domain δ = set X  ground (subst_range δ)
                         t  δ  t'  δ  t  δ    t'  δ  )"
using assms
proof (induction rule: strand_sem_induct)
  case (ConsIneq M Y F S) thus ?case
  proof (cases "Inequality X [(t,t')]  set S")
    case False
    hence "X = Y" "F = [(t,t')]" using ConsIneq by auto
    hence *: "θ. subst_domain θ = set X  ground (subst_range θ)  t  θ    t'  θ  "
      using ConsIneq by (auto simp add: ineq_model_def)
    then obtain θ where θ: "subst_domain θ = set X" "ground (subst_range θ)" "t  θ    t'  θ  "
      using interpretation_subst_exists'[of "set X"] by moura
    hence "t  t'" by auto
    moreover have " θ. t  θ    t'  θ    t  θ  t'  θ" by auto
    ultimately show ?thesis using * by auto
  qed simp
qed simp_all

lemma strand_sem_c_imp_ineq_model:
  assumes "M; Sc " "Inequality X F  set S"
  shows "ineq_model  X F"
using assms by (induct S rule: strand_sem_induct) force+

lemma strand_sem_wf_simple_fv_sat:
  assumes "wfst {} S" "simple S" "{}; Sc "
  shows "v. v  wfrestrictedvarsst S  ikst S set  c  v"
using assms
proof (induction S rule: wfst_simple_induct)
  case (ConsRcv t S)
  have "v  wfrestrictedvarsst S"
    using ConsRcv.hyps(3) ConsRcv.prems(1) vars_snd_rcv_strand2
    by fastforce
  moreover have "{}; Sc " using {}; S@[Receive t]c  by blast
  moreover have "ikst S set   ikst (S@[Receive t]) set " by auto
  ultimately show ?case using ConsRcv.IH ideduct_synth_mono by meson
next
  case (ConsIneq X F S)
  hence "v  wfrestrictedvarsst S" by fastforce
  moreover have "{}; Sc " using {}; S@[Inequality X F]c  by blast
  moreover have "ikst S set   ikst (S@[Inequality X F]) set " by auto
  ultimately show ?case using ConsIneq.IH ideduct_synth_mono by meson
next
  case (ConsSnd w S)
  hence *: "{}; Sc " "ikst S set  c  w" by auto
  have **: "ikst S set   ikst (S@[Send (Var w)]) set " by simp
  show ?case
  proof (cases "v = w")
    case True thus ?thesis using *(2) ideduct_synth_mono[OF _ **] by meson
  next
    case False
    hence "v  wfrestrictedvarsst S" using ConsSnd.prems(1) by auto
    thus ?thesis using ConsSnd.IH[OF _ *(1)] ideduct_synth_mono[OF _ **] by metis
  qed
qed simp

lemma strand_sem_wf_ik_or_assignment_rhs_fun_subterm:
  assumes "wfst {} A" "{}; Ac " "Var x  ikst A" " x = Fun f T"
          "ti  set T" "¬ikst A set  c ti" "interpretationsubst "
  obtains S where
    "Fun f S  subtermsset (ikst A)  Fun f S  subtermsset (assignment_rhsst A)"
    "Fun f T = Fun f S  "
proof -
  have "x  wfrestrictedvarsst A"
    by (metis (no_types) assms(3) set_rev_mp term.set_intros(3) vars_subset_if_in_strand_ik2)
  moreover have "Fun f T   = Fun f T"
    by (metis subst_ground_ident interpretation_grounds_all assms(4,7))
  ultimately obtain Apre Asuf where *:
      "¬(w  wfrestrictedvarsst Apre. Fun f T   w)"
      "(t. A = Apre@Send t#Asuf  Fun f T  t  ) 
       (t t'. A = Apre@Equality Assign t t'#Asuf  Fun f T  t  )"
    using wf_strand_first_Send_var_split[OF assms(1)] assms(4) subtermeqI' by metis
  moreover
  { fix t assume **: "A = Apre@Send t#Asuf" "Fun f T  t  "
    hence "ikst Apre set  c t  " "¬ikst Apre set  c ti"
      using assms(2,6) by (auto intro: ideduct_synth_mono)
    then obtain s where s: "s  ikst Apre" "Fun f T  s  "
      using assms(5) **(2) by (induct rule: intruder_synth_induct) auto
    then obtain g S where gS: "Fun g S  s" "Fun f T = Fun g S  "
      using subterm_subst_not_img_subterm[OF s(2)] *(1) by force
    hence ?thesis using that **(1) s(1) by force
  }
  moreover
  { fix t t' assume **: "A = Apre@Equality Assign t t'#Asuf" "Fun f T  t  "
    with assms(2) have "t   = t'  " by auto
    hence "Fun f T  t'  " using **(2) by auto
    from assms(1) **(1) have "fv t'  wfrestrictedvarsst Apre"
      using wf_eq_fv[of "{}" Apre t t' Asuf] vars_snd_rcv_strand_subset2(4)[of Apre]
      by blast
    then obtain g S where gS: "Fun g S  t'" "Fun f T = Fun g S  "
      using subterm_subst_not_img_subterm[OF ‹Fun f T  t'  ] *(1) by fastforce
    hence ?thesis using that **(1) by auto
  }
  ultimately show ?thesis by auto
qed

lemma strand_sem_not_unif_is_sat_ineq:
  assumes "θ. Unifier θ t t'"
  shows "M; [Inequality X [(t,t')]]c " "M; [Inequality X [(t,t')]]d "
using assms list_ex_simps(1)[of _ "(t,t')" "[]"] prod.sel[of t t']
      strand_sem_c.simps(1,5) strand_sem_d.simps(1,5)
unfolding ineq_model_def by presburger+

lemma ineq_model_singleI[intro]:
  assumes "δ. subst_domain δ = set X  ground (subst_range δ)  t  δ    t'  δ  "
  shows "ineq_model  X [(t,t')]"
using assms unfolding ineq_model_def by auto

lemma ineq_model_singleE:
  assumes "ineq_model  X [(t,t')]"
  shows "δ. subst_domain δ = set X  ground (subst_range δ)  t  δ    t'  δ  "
using assms unfolding ineq_model_def by auto

lemma ineq_model_single_iff:
  fixes F::"(('a,'b) term × ('a,'b) term) list"
  shows "ineq_model  X F 
         ineq_model  X [(Fun f (Fun c []#map fst F),Fun f (Fun c []#map snd F))]"
    (is "?A  ?B")
proof -
  let ?P = "λδ f. fst f  (δ s )  snd f  (δ s )"
  let ?Q = "λδ t t'. t  (δ s )  t'  (δ s )"
  let ?T = "λg. Fun c []#map g F"
  let ?S = "λδ g. map (λx. x  (δ s )) (Fun c []#map g F)"
  let ?t = "Fun f (?T fst)"
  let ?t' = "Fun f (?T snd)"

  have len: "g h. length (?T g) = length (?T h)"
            "g h δ. length (?S δ g) = length (?T h)"
            "g h δ. length (?S δ g) = length (?T h)"
            "g h δ σ. length (?S δ g) = length (?S σ h)"
    by simp_all

  { fix δ::"('a,'b) subst"
    assume δ: "subst_domain δ = set X" "ground (subst_range δ)"
    have "list_ex (?P δ) F  ?Q δ ?t ?t'"
    proof
      assume "list_ex (?P δ) F"
      then obtain a where a: "a  set F" "?P δ a" by (metis (mono_tags, lifting) Bex_set)
      thus "?Q δ ?t ?t'" by auto
    qed (fastforce simp add: Bex_set)
  } thus ?thesis unfolding ineq_model_def by auto
qed


subsection ‹Constraint Semantics (Alternative, Equivalent Version)›
text ‹These are the constraint semantics used in the CSF 2017 paper›
fun strand_sem_c'::"('fun,'var) terms  ('fun,'var) strand  ('fun,'var) subst  bool"  ("_; _c''") 
  where
  "M; []c' = (λ. True)"
| "M; Send t#Sc' = (λ. M set  c t    M; Sc' )"
| "M; Receive t#Sc' = insert t M; Sc'"
| "M; Equality _ t t'#Sc' = (λ. t   = t'    M; Sc' )"
| "M; Inequality X F#Sc' = (λ. ineq_model  X F  M; Sc' )"

fun strand_sem_d'::"('fun,'var) terms  ('fun,'var) strand  ('fun,'var) subst  bool" ("_; _d''")
where
  "M; []d' = (λ. True)"
| "M; Send t#Sd' = (λ. M set   t    M; Sd' )"
| "M; Receive t#Sd' = insert t M; Sd'"
| "M; Equality _ t t'#Sd' = (λ. t   = t'    M; Sd' )"
| "M; Inequality X F#Sd' = (λ. ineq_model  X F  M; Sd' )"

lemma strand_sem_eq_defs:
  "M; 𝒜c'  = M set ; 𝒜c "
  "M; 𝒜d'  = M set ; 𝒜d "
proof -
  have 1: "M; 𝒜c'   M set ; 𝒜c "
    by (induct 𝒜 arbitrary: M rule: strand_sem_induct) force+
  have 2: "M set ; 𝒜c   M; 𝒜c' "
    by (induct 𝒜 arbitrary: M rule: strand_sem_c'.induct) auto
  have 3: "M; 𝒜d'   M set ; 𝒜d "
    by (induct 𝒜 arbitrary: M rule: strand_sem_induct) force+
  have 4: "M set ; 𝒜d   M; 𝒜d' "
    by (induct 𝒜 arbitrary: M rule: strand_sem_d'.induct) auto

  show "M; 𝒜c'  = M set ; 𝒜c " "M; 𝒜d'  = M set ; 𝒜d "
    by (metis 1 2, metis 3 4)
qed

lemma strand_sem_split'[dest]:
  "M; S@S'c' θ  M; Sc' θ" 
  "M; S@S'c' θ  M  ikst S; S'c' θ"
  "M; S@S'd' θ  M; Sd' θ"
  "M; S@S'd' θ  M  ikst S; S'd' θ"
using strand_sem_eq_defs[of M "S@S'" θ]
      strand_sem_eq_defs[of M S θ]
      strand_sem_eq_defs[of "M  ikst S" S' θ]
      strand_sem_split(2,4)
by (auto simp add: image_Un)

lemma strand_sem_append'[intro]:
  "M; Sc' θ  M  ikst S; S'c' θ  M; S@S'c' θ"
  "M; Sd' θ  M  ikst S; S'd' θ  M; S@S'd' θ"
using strand_sem_eq_defs[of M "S@S'" θ]
      strand_sem_eq_defs[of M S θ]
      strand_sem_eq_defs[of "M  ikst S" S' θ]
by (auto simp add: image_Un)

end

subsection ‹Dual Strands›
fun dualst::"('a,'b) strand  ('a,'b) strand" where
  "dualst [] = []"
| "dualst (Receive t#S) = Send t#(dualst S)"
| "dualst (Send t#S) = Receive t#(dualst S)"
| "dualst (x#S) = x#(dualst S)"

lemma dualst_append: "dualst (A@B) = (dualst A)@(dualst B)"
by (induct A rule: dualst.induct) auto

lemma dualst_self_inverse: "dualst (dualst S) = S"
proof (induction S)
  case (Cons x S) thus ?case by (cases x) auto
qed simp

lemma dualst_trms_eq: "trmsst (dualst S) = trmsst S"
proof (induction S)
  case (Cons x S) thus ?case by (cases x) auto
qed simp

lemma dualst_fv: "fvst (dualst A) = fvst A"
by (induct A rule: dualst.induct) auto

lemma dualst_bvars: "bvarsst (dualst A) = bvarsst A"
by (induct A rule: dualst.induct) fastforce+


end

Theory Lazy_Intruder

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Lazy_Intruder.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹The Lazy Intruder›
theory Lazy_Intruder
imports Strands_and_Constraints Intruder_Deduction
begin

context intruder_model
begin

subsection ‹Definition of the Lazy Intruder›
text ‹The lazy intruder constraint reduction system, defined as a relation on constraint states›
inductive_set LI_rel::
    "((('fun,'var) strand × (('fun,'var) subst)) ×
       ('fun,'var) strand × (('fun,'var) subst)) set"
  and LI_rel' (infix "" 50)
  and LI_rel_trancl (infix "+" 50)
  and LI_rel_rtrancl (infix "*" 50)
where
  "A  B  (A,B)  LI_rel"
| "A + B  (A,B)  LI_rel+"
| "A * B  (A,B)  LI_rel*"

| Compose: "simple S; length T = arity f; public f
             (S@Send (Fun f T)#S',θ)  (S@(map Send T)@S',θ)"
| Unify: "simple S; Fun f T'  ikst S; Some δ = mgu (Fun f T) (Fun f T')
           (S@Send (Fun f T)#S',θ)  ((S@S') st δ,θ s δ)"
| Equality: "simple S; Some δ = mgu t t'
           (S@Equality _ t t'#S',θ)  ((S@S') st δ,θ s δ)"


subsection ‹Lemma: The Lazy Intruder is Well-founded›
context
begin
private lemma LI_compose_measure_lt: "((S@(map Send T)@S',θ1), (S@Send (Fun f T)#S',θ2))  measurest"
using strand_fv_card_map_fun_eq[of S f T S'] strand_size_map_fun_lt(2)[of T f]
by (simp add: measurest_def sizest_def)

private lemma LI_unify_measure_lt:
  assumes "Some δ = mgu (Fun f T) t" "fv t  fvst S"
  shows "(((S@S') st δ,θ1), (S@Send (Fun f T)#S',θ2))  measurest"
proof (cases "δ = Var")
  assume "δ = Var"
  hence "(S@S') st δ = S@S'" by blast
  thus ?thesis
    using strand_fv_card_rm_fun_le[of S S' f T]
    by (auto simp add: measurest_def sizest_def)
next
  assume "δ  Var"
  then obtain v where "v  fv (Fun f T)  fv t" "subst_elim δ v"
    using mgu_eliminates[OF assms(1)[symmetric]] by metis
  hence v_in: "v  fvst (S@Send (Fun f T)#S')"
    using assms(2) by (auto simp add: measurest_def sizest_def)
  
  have "range_vars δ  fv (Fun f T)  fvst S"
    using assms(2) mgu_vars_bounded[OF assms(1)[symmetric]] by auto
  hence img_bound: "range_vars δ  fvst (S@Send (Fun f T)#S')" by auto

  have finite_fv: "finite (fvst (S@Send (Fun f T)#S'))" by auto

  have "v  fvst ((S@Send (Fun f T)#S') st δ)"
    using strand_fv_subst_subset_if_subst_elim[OF ‹subst_elim δ v] v_in by metis
  hence v_not_in: "v  fvst ((S@S') st δ)" by auto
  
  have "fvst ((S@S') st δ)  fvst (S@Send (Fun f T)#S')"
    using strand_subst_fv_bounded_if_img_bounded[OF img_bound] by simp
  hence "fvst ((S@S') st δ)  fvst (S@Send (Fun f T)#S')" using v_in v_not_in by blast
  hence "card (fvst ((S@S') st δ)) < card (fvst (S@Send (Fun f T)#S'))"
    using psubset_card_mono[OF finite_fv] by simp
  thus ?thesis by (auto simp add: measurest_def sizest_def)
qed

private lemma LI_equality_measure_lt:
  assumes "Some δ = mgu t t'"
  shows "(((S@S') st δ,θ1), (S@Equality a t t'#S',θ2))  measurest"
proof (cases "δ = Var")
  assume "δ = Var"
  hence "(S@S') st δ = S@S'" by blast
  thus ?thesis
    using strand_fv_card_rm_eq_le[of S S' a t t']
    by (auto simp add: measurest_def sizest_def)
next
  assume "δ  Var"
  then obtain v where "v  fv t  fv t'" "subst_elim δ v"
    using mgu_eliminates[OF assms(1)[symmetric]] by metis
  hence v_in: "v  fvst (S@Equality a t t'#S')" using assms by auto
  
  have "range_vars δ  fv t  fv t'  fvst S"
    using assms mgu_vars_bounded[OF assms(1)[symmetric]] by auto
  hence img_bound: "range_vars δ  fvst (S@Equality a t t'#S')" by auto

  have finite_fv: "finite (fvst (S@Equality a t t'#S'))" by auto

  have "v  fvst ((S@Equality a t t'#S') st δ)"
    using strand_fv_subst_subset_if_subst_elim[OF ‹subst_elim δ v] v_in by metis
  hence v_not_in: "v  fvst ((S@S') st δ)" by auto
  
  have "fvst ((S@S') st δ)  fvst (S@Equality a t t'#S')"
    using strand_subst_fv_bounded_if_img_bounded[OF img_bound] by simp
  hence "fvst ((S@S') st δ)  fvst (S@Equality a t t'#S')" using v_in v_not_in by blast
  hence "card (fvst ((S@S') st δ)) < card (fvst (S@Equality a t t'#S'))"
    using psubset_card_mono[OF finite_fv] by simp
  thus ?thesis by (auto simp add: measurest_def sizest_def)
qed

private lemma LI_in_measure: "(S1,θ1)  (S2,θ2)  ((S2,θ2),(S1,θ1))  measurest"
proof (induction rule: LI_rel.induct)
  case (Compose S T f S' θ) thus ?case using LI_compose_measure_lt[of S T S'] by metis
next
  case (Unify S f U δ T S' θ)
  hence "fv (Fun f U)  fvst S"
    using fv_snd_rcv_strand_subset(2)[of S] by force
  thus ?case using LI_unify_measure_lt[OF Unify.hyps(3), of S S'] by metis
qed (metis LI_equality_measure_lt)

private lemma LI_in_measure_trans: "(S1,θ1) + (S2,θ2)  ((S2,θ2),(S1,θ1))  measurest"
by (induction rule: trancl.induct, metis surjective_pairing LI_in_measure)
   (metis (no_types, lifting) surjective_pairing LI_in_measure measurest_trans trans_def)

private lemma LI_converse_wellfounded_trans: "wf ((LI_rel+)¯)"
proof -
  have "(LI_rel+)¯  measurest" using LI_in_measure_trans by auto
  thus ?thesis using measurest_wellfounded wf_subset by metis
qed

private lemma LI_acyclic_trans: "acyclic (LI_rel+)"
using wf_acyclic[OF LI_converse_wellfounded_trans] acyclic_converse by metis

private lemma LI_acyclic: "acyclic LI_rel"
using LI_acyclic_trans acyclic_subset by (simp add: acyclic_def)

lemma LI_no_infinite_chain: "¬(f. i. f i + f (Suc i))"
proof -
  have "¬(f. i. (f (Suc i), f i)  (LI_rel+)¯)"
    using wf_iff_no_infinite_down_chain LI_converse_wellfounded_trans by metis
  thus ?thesis by simp
qed

private lemma LI_unify_finite:
  assumes "finite M"
  shows "finite {((S@Send (Fun f T)#S',θ), ((S@S') st δ,θ s δ)) | δ T'. 
                   simple S  Fun f T'  M  Some δ = mgu (Fun f T) (Fun f T')}"
using assms
proof (induction M rule: finite_induct)
  case (insert m M) thus ?case
  proof (cases m)
    case (Fun g U)
    let ?a = "λδ. ((S@Send (Fun f T)#S',θ), ((S@S') st δ,θ s δ))"
    let ?A = "λB. {?a δ | δ T'. simple S  Fun f T'  B  Some δ = mgu (Fun f T) (Fun f T')}"

    have "?A (insert m M) = (?A M)  (?A {m})" by auto
    moreover have "finite (?A {m})"
    proof (cases "δ. Some δ = mgu (Fun f T) (Fun g U)")
      case True
      then obtain δ where δ: "Some δ = mgu (Fun f T) (Fun g U)" by blast
      
      have A_m_eq: "δ'. ?a δ'  ?A {m}  ?a δ = ?a δ'"
      proof -
        fix δ' assume "?a δ'  ?A {m}"
        hence "σ. Some σ = mgu (Fun f T) (Fun g U)  ?a σ = ?a δ'"
          using m = Fun g U by auto
        thus "?a δ = ?a δ'" by (metis δ option.inject)
      qed

      have "?A {m} = {}  ?A {m} = {?a δ}"
      proof (cases "simple S  ?A {m}  {}")
        case True
        hence "simple S" "?A {m}  {}" by meson+
        hence "?A {m} = {?a δ | δ. Some δ = mgu (Fun f T) (Fun g U)}" using m = Fun g U by auto
        hence "?a δ  ?A {m}" using δ by auto
       show ?thesis
        proof (rule ccontr)
          assume "¬(?A {m} = {}  ?A {m} = {?a δ})"
          then obtain B where B: "?A {m} = insert (?a δ) B" "?a δ  B" "B  {}"
            using ?A {m}  {} ?a δ  ?A {m} by (metis (no_types, lifting) Set.set_insert)
          then obtain b where b: "?a δ  b" "b  B" by (metis (no_types, lifting) ex_in_conv)
          then obtain δ' where δ': "b = ?a δ'" using B(1) by blast
          moreover have "?a δ'  ?A {m}" using B(1) b(2) δ' by auto
          hence "?a δ = ?a δ'" by (blast dest!: A_m_eq)
          ultimately show False using b(1) by simp
        qed
      qed auto
      thus ?thesis by (metis (no_types, lifting) finite.emptyI finite_insert) 
    next
      case False
      hence "?A {m} = {}" using m = Fun g U by blast
      thus ?thesis by (metis finite.emptyI)
    qed
    ultimately show ?thesis using insert.IH by auto
  qed simp
qed fastforce
end


subsection ‹Lemma: The Lazy Intruder Preserves Well-formedness›
context
begin
private lemma LI_preserves_subst_wf_single:
  assumes "(S1,θ1)  (S2,θ2)" "fvst S1  bvarsst S1 = {}" "wfsubst θ1"
  and "subst_domain θ1  varsst S1 = {}" "range_vars θ1  bvarsst S1 = {}"
  shows "fvst S2  bvarsst S2 = {}" "wfsubst θ2"
  and "subst_domain θ2  varsst S2 = {}" "range_vars θ2  bvarsst S2 = {}"
using assms
proof (induction rule: LI_rel.induct)
  case (Compose S X f S' θ)
  { case 1 thus ?case using vars_st_snd_map by auto }
  { case 2 thus ?case using vars_st_snd_map by auto }
  { case 3 thus ?case using vars_st_snd_map by force }
  { case 4 thus ?case using vars_st_snd_map by auto }
next
  case (Unify S f U δ T S' θ)
  hence "fv (Fun f U)  fvst S" using fv_subset_if_in_strand_ik' by blast
  hence *: "subst_domain δ  range_vars δ  fvst (S@Send (Fun f T)#S')"
    using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]]
    unfolding range_vars_alt_def by (fastforce simp del: subst_range.simps)

  have "fvst (S@S')  fvst (S@Send (Fun f T)#S')" "varsst (S@S')  varsst (S@Send (Fun f T)#S')"
    by auto
  hence **: "fvst (S@S' st δ)  fvst (S@Send (Fun f T)#S')"
            "varsst (S@S' st δ)  varsst (S@Send (Fun f T)#S')"
    using subst_sends_strand_fv_to_img[of "S@S'" δ]
          strand_subst_vars_union_bound[of "S@S'" δ] *
    by blast+

  have "wfsubst δ" by (fact mgu_gives_wellformed_subst[OF Unify.hyps(3)[symmetric]])
  
  { case 1
    have "bvarsst (S@S' st δ) = bvarsst (S@Send (Fun f T)#S')"
      using bvars_subst_ident[of "S@S'" δ] by auto
    thus ?case using 1 ** by blast
  }
  { case 2
    hence "subst_domain θ  subst_domain δ = {}" "subst_domain θ  range_vars δ = {}"
      using * by blast+
    thus ?case by (metis wf_subst_compose[OF ‹wfsubst θ ‹wfsubst δ])
  }
  { case 3
    hence "subst_domain θ  varsst (S@S' st δ) = {}" using ** by blast
    moreover have "v  fvst (S@Send (Fun f T)#S')" when "v  subst_domain δ" for v
      using * that by blast
    hence "subst_domain δ  fvst (S@S' st δ) = {}"
      using mgu_eliminates_dom[OF Unify.hyps(3)[symmetric],
                THEN strand_fv_subst_subset_if_subst_elim, of _ "S@Send (Fun f T)#S'"]
      unfolding subst_elim_def by auto
    moreover have "bvarsst (S@S' st δ) = bvarsst (S@Send (Fun f T)#S')"
      using bvars_subst_ident[of "S@S'" δ] by auto
    hence "subst_domain δ  bvarsst (S@S' st δ) = {}" using 3(1) * by blast
    ultimately show ?case
      using ** * subst_domain_compose[of θ δ] varsst_is_fvst_bvarsst[of "S@S' st δ"]
      by blast
  }
  { case 4
    have ***: "bvarsst (S@S' st δ) = bvarsst (S@Send (Fun f T)#S')"
      using bvars_subst_ident[of "S@S'" δ] by auto
    hence "range_vars δ  bvarsst (S@S' st δ) = {}" using 4(1) * by blast
    thus ?case using subst_img_comp_subset[of θ δ] 4(4) *** by blast
  }
next
  case (Equality S δ t t' a S' θ)
  hence *: "subst_domain δ  range_vars δ  fvst (S@Equality a t t'#S')"
    using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]]
    unfolding range_vars_alt_def by fastforce

  have "fvst (S@S')  fvst (S@Equality a t t'#S')" "varsst (S@S')  varsst (S@Equality a t t'#S')"
    by auto
  hence **: "fvst (S@S' st δ)  fvst (S@Equality a t t'#S')"
            "varsst (S@S' st δ)  varsst (S@Equality a t t'#S')"
    using subst_sends_strand_fv_to_img[of "S@S'" δ]
          strand_subst_vars_union_bound[of "S@S'" δ] *
    by blast+

  have "wfsubst δ" by (fact mgu_gives_wellformed_subst[OF Equality.hyps(2)[symmetric]])
  
  { case 1
    have "bvarsst (S@S' st δ) = bvarsst (S@Equality a t t'#S')"
      using bvars_subst_ident[of "S@S'" δ] by auto
    thus ?case using 1 ** by blast
  }
  { case 2
    hence "subst_domain θ  subst_domain δ = {}" "subst_domain θ  range_vars δ = {}"
      using * by blast+
    thus ?case by (metis wf_subst_compose[OF ‹wfsubst θ ‹wfsubst δ])
  }
  { case 3
    hence "subst_domain θ  varsst (S@S' st δ) = {}" using ** by blast
    moreover have "v  fvst (S@Equality a t t'#S')" when "v  subst_domain δ" for v
      using * that by blast
    hence "subst_domain δ  fvst (S@S' st δ) = {}"
      using mgu_eliminates_dom[OF Equality.hyps(2)[symmetric],
                THEN strand_fv_subst_subset_if_subst_elim, of _ "S@Equality a t t'#S'"]
      unfolding subst_elim_def by auto
    moreover have "bvarsst (S@S' st δ) = bvarsst (S@Equality a t t'#S')"
      using bvars_subst_ident[of "S@S'" δ] by auto
    hence "subst_domain δ  bvarsst (S@S' st δ) = {}" using 3(1) * by blast
    ultimately show ?case
      using ** * subst_domain_compose[of θ δ] varsst_is_fvst_bvarsst[of "S@S' st δ"]
      by blast
  }
  { case 4
    have ***: "bvarsst (S@S' st δ) = bvarsst (S@Equality a t t'#S')"
      using bvars_subst_ident[of "S@S'" δ] by auto
    hence "range_vars δ  bvarsst (S@S' st δ) = {}" using 4(1) * by blast
    thus ?case using subst_img_comp_subset[of θ δ] 4(4) *** by blast
  }
qed

private lemma LI_preserves_subst_wf:
  assumes "(S1,θ1) * (S2,θ2)" "fvst S1  bvarsst S1 = {}" "wfsubst θ1"
  and "subst_domain θ1  varsst S1 = {}" "range_vars θ1  bvarsst S1 = {}"
  shows "fvst S2  bvarsst S2 = {}" "wfsubst θ2"
  and "subst_domain θ2  varsst S2 = {}" "range_vars θ2  bvarsst S2 = {}"
using assms
proof (induction S2 θ2 rule: rtrancl_induct2)
  case (step Si θi Sj θj)
  { case 1 thus ?case using LI_preserves_subst_wf_single[OF (Si,θi)  (Sj,θj)] step.IH by metis }
  { case 2 thus ?case using LI_preserves_subst_wf_single[OF (Si,θi)  (Sj,θj)] step.IH by metis }
  { case 3 thus ?case using LI_preserves_subst_wf_single[OF (Si,θi)  (Sj,θj)] step.IH by metis }
  { case 4 thus ?case using LI_preserves_subst_wf_single[OF (Si,θi)  (Sj,θj)] step.IH by metis }
qed metis

lemma LI_preserves_wellformedness:
  assumes "(S1,θ1) * (S2,θ2)" "wfconstr S1 θ1"
  shows "wfconstr S2 θ2"
proof -
  have *: "wfst {} Sj"
    when "(Si, θi)  (Sj, θj)" "wfconstr Si θi" for Si θi Sj θj
    using that
  proof (induction rule: LI_rel.induct)
    case (Unify S f U δ T S' θ)
    have "fv (Fun f T)  fv (Fun f U)  fvst (S@Send (Fun f T)#S')" using Unify.hyps(2) by force
    hence "subst_domain δ  range_vars δ  fvst (S@Send (Fun f T)#S')"
      using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] by (metis subset_trans)
    hence "(subst_domain δ  range_vars δ)  bvarsst (S@Send (Fun f T)#S') = {}"
      using Unify.prems unfolding wfconstr_def by blast
    thus ?case
      using wf_unify[OF _ Unify.hyps(2) MGU_is_Unifier[OF mgu_gives_MGU], of "{}",
                     OF _ Unify.hyps(3)[symmetric], of S'] Unify.prems(1)
      by (auto simp add: wfconstr_def)
  next
    case (Equality S δ t t' a S' θ)
    have "fv t  fv t'  fvst (S@Equality a t t'#S')" using Equality.hyps(2) by force
    hence "subst_domain δ  range_vars δ  fvst (S@Equality a t t'#S')"
      using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] by (metis subset_trans)
    hence "(subst_domain δ  range_vars δ)  bvarsst (S@Equality a t t'#S') = {}"
      using Equality.prems unfolding wfconstr_def by blast
    thus ?case
      using wf_equality[OF _ Equality.hyps(2)[symmetric], of "{}" S a S'] Equality.prems(1)
      by (auto simp add: wfconstr_def)
  qed (metis wf_send_compose wfconstr_def)

  show ?thesis using assms
  proof (induction rule: rtrancl_induct2)
    case (step Si θi Sj θj) thus ?case
      using LI_preserves_subst_wf_single[OF (Si,θi)  (Sj,θj)] *[OF (Si,θi)  (Sj,θj)]
      by (metis wfconstr_def)
  qed simp
qed

lemma LI_preserves_trm_wf:
  assumes "(S,θ) * (S',θ')" "wftrms (trmsst S)"
  shows "wftrms (trmsst S')"
proof -
  { fix S θ S' θ'
    assume "(S,θ)  (S',θ')" "wftrms (trmsst S)"
    hence "wftrms (trmsst S')"
    proof (induction rule: LI_rel.induct)
      case (Compose S T f S' θ)
      hence "wftrm (Fun f T)"
        and *: "t  set S  wftrms (trmsstp t)" "t  set S'  wftrms (trmsstp t)" for t
        by auto
      hence "wftrm t" when "t  set T" for t using that unfolding wftrm_def by auto
      hence "wftrms (trmsstp t)" when "t  set (map Send T)" for t
        using that unfolding wftrm_def by auto
      thus ?case using * by force
    next
      case (Unify S f U δ T S' θ)
      have "wftrm (Fun f T)" "wftrm (Fun f U)"
        using Unify.prems(1) Unify.hyps(2) wf_trm_subterm[of _ "Fun f U"]
        by (simp, force)
      hence range_wf: "wftrms (subst_range δ)"
        using mgu_wf_trm[OF Unify.hyps(3)[symmetric]] by simp

      { fix s assume "s  set (S@S' st δ)"
        hence "s'  set (S@S'). s = s' stp δ  wftrms (trmsstp s')"
          using Unify.prems(1) by (auto simp add: subst_apply_strand_def)
        moreover {
          fix s' assume s': "s = s' stp δ" "wftrms (trmsstp s')" "s'  set (S@S')"
          from s'(2) have "trmsstp (s' stp δ) = trmsstp s' set (rm_vars (set (bvarsstp s')) δ)"
          proof (induction s')
            case (Inequality X F) thus ?case by (induct F) (auto simp add: subst_apply_pairs_def)
          qed auto
          hence "wftrms (trmsstp s)"
            using wf_trm_subst[OF wf_trms_subst_rm_vars'[OF range_wf]] ‹wftrms (trmsstp s') s'(1)
            by simp
        }
        ultimately have "wftrms (trmsstp s)" by auto
      }
      thus ?case by auto
    next
      case (Equality S δ t t' a S' θ)
      hence "wftrm t" "wftrm t'" by simp_all
      hence range_wf: "wftrms (subst_range δ)"
        using mgu_wf_trm[OF Equality.hyps(2)[symmetric]] by simp

      { fix s assume "s  set (S@S' st δ)"
        hence "s'  set (S@S'). s = s' stp δ  wftrms (trmsstp s')"
          using Equality.prems(1) by (auto simp add: subst_apply_strand_def)
        moreover {
          fix s' assume s': "s = s' stp δ" "wftrms (trmsstp s')" "s'  set (S@S')"
          from s'(2) have "trmsstp (s' stp δ) = trmsstp s' set (rm_vars (set (bvarsstp s')) δ)"
          proof (induction s')
            case (Inequality X F) thus ?case by (induct F) (auto simp add: subst_apply_pairs_def)
          qed auto
          hence "wftrms (trmsstp s)"
            using wf_trm_subst[OF wf_trms_subst_rm_vars'[OF range_wf]] ‹wftrms (trmsstp s') s'(1)
            by simp
        }
        ultimately have "wftrms (trmsstp s)" by auto
      }
      thus ?case by auto
    qed
  }
  with assms show ?thesis by (induction rule: rtrancl_induct2) metis+
qed
end

subsection ‹Theorem: Soundness of the Lazy Intruder›
context
begin
private lemma LI_soundness_single:
  assumes "wfconstr S1 θ1" "(S1,θ1)  (S2,θ2)" " c S2,θ2"
  shows " c S1,θ1"
using assms(2,1,3)
proof (induction rule: LI_rel.induct)
  case (Compose S T f S' θ)
  hence *: "{}; Sc " "ikst S set ; map Send Tc " "ikst S set ; S'c "
    unfolding constr_sem_c_def by force+

  have "ikst S set  c Fun f T  "
    using *(2) Compose.hyps(2) ComposeC[OF _ Compose.hyps(3), of "map (λx. x  ) T"]
    unfolding subst_compose_def by force
  thus " c S@Send (Fun f T)#S',θ"
    using *(1,3)  c S@map Send T@S',θ
    by (auto simp add: constr_sem_c_def)
next
  case (Unify S f U δ T S' θ)
  have "(θ s δ) supports " "{}; S@S' st δc "
    using Unify.prems(2) unfolding constr_sem_c_def by metis+
  then obtain σ where σ: "θ s δ s σ = " unfolding subst_compose_def by auto

  have θfun_id: "Fun f U  θ = Fun f U" "Fun f T  θ = Fun f T"
    using Unify.prems(1) trm_subst_ident[of "Fun f U" θ]
          fv_subset_if_in_strand_ik[of "Fun f U" S] Unify.hyps(2)
          fv_snd_rcv_strand_subset(2)[of S]
          strand_vars_split(1)[of S "Send (Fun f T)#S'"]
    unfolding wfconstr_def apply blast
    using Unify.prems(1) trm_subst_ident[of "Fun f T" θ]
    unfolding wfconstr_def by fastforce
  hence θδ_disj:
      "subst_domain θ  subst_domain δ = {}"
      "subst_domain θ  range_vars δ = {}"
      "subst_domain θ  range_vars θ = {}" 
    using trm_subst_disj mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] apply (blast,blast)
    using Unify.prems(1) unfolding wfconstr_def wfsubst_def by blast
  hence θδ_support: "θ supports " "δ supports "
    by (simp_all add: subst_support_comp_split[OF (θ s δ) supports ])

  have "fv (Fun f T)  fvst (S@Send (Fun f T)#S')" "fv (Fun f U)  fvst (S@Send (Fun f T)#S')"
    using Unify.hyps(2) by force+
  hence δ_vars_bound: "subst_domain δ  range_vars δ  fvst (S@Send (Fun f T)#S')"
    using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] by blast

  have "ikst S set ; [Send (Fun f T)]c "
  proof -
    from Unify.hyps(2) have "Fun f U    ikst S set " by blast
    hence "Fun f U    ikst S set " by blast
    moreover have "Unifier δ (Fun f T) (Fun f U)"
      by (fact MGU_is_Unifier[OF mgu_gives_MGU[OF Unify.hyps(3)[symmetric]]])
    ultimately have "Fun f T    ikst S set "
      using σ by (metis θfun_id subst_subst_compose) 
    thus ?thesis by simp
  qed

  have "{}; Sc " "ikst S set ; S'c "
  proof -
    have "(S@S' st δ) st θ = S@S' st δ" "(S@S') st θ = S@S'"
    proof -
      have "subst_domain θ  varsst (S@S') = {}"
        using Unify.prems(1) by (auto simp add: wfconstr_def)
      hence "subst_domain θ  varsst (S@S' st δ) = {}"
        using θδ_disj(2) strand_subst_vars_union_bound[of "S@S'" δ] by blast
      thus "(S@S' st δ) st θ = S@S' st δ" "(S@S') st θ = S@S'"
        using strand_subst_comp ‹subst_domain θ  varsst (S@S') = {} by (blast,blast)
    qed
    moreover have "subst_idem δ" by (fact mgu_gives_subst_idem[OF Unify.hyps(3)[symmetric]])
    moreover have
        "(subst_domain θ  range_vars θ)  bvarsst (S@S') = {}"
        "(subst_domain θ  range_vars θ)  bvarsst (S@S' st δ) = {}"
        "(subst_domain δ  range_vars δ)  bvarsst (S@S') = {}"
      using wf_constr_bvars_disj[OF Unify.prems(1)]
            wf_constr_bvars_disj'[OF Unify.prems(1) δ_vars_bound]
      by auto
    ultimately have "{}; S@S'c "
      using {}; S@S' st δc  σ
            strand_sem_subst(1)[of θ "S@S' st δ" "{}" "δ s σ"]
            strand_sem_subst(2)[of θ "S@S'" "{}" "δ s σ"] 
            strand_sem_subst_subst_idem[of δ "S@S'" "{}" σ]
      unfolding constr_sem_c_def
      by (metis subst_compose_assoc)
    thus "{}; Sc " "ikst S set ; S'c " by auto
  qed
  
  show " c S@Send (Fun f T)#S',θ"
    using θδ_support(1) ikst S set ; [Send (Fun f T)]c  {}; Sc  ikst S set ; S'c 
    by (auto simp add: constr_sem_c_def)
next
  case (Equality S δ t t' a S' θ)
  have "(θ s δ) supports " "{}; S@S' st δc "
    using Equality.prems(2) unfolding constr_sem_c_def by metis+
  then obtain σ where σ: "θ s δ s σ = " unfolding subst_compose_def by auto

  have "fv t  varsst (S@Equality a t t'#S')" "fv t'  varsst (S@Equality a t t'#S')"
    by auto
  moreover have "subst_domain θ  varsst (S@Equality a t t'#S') = {}"
    using Equality.prems(1) unfolding wfconstr_def by auto
  ultimately have θfun_id: "t  θ = t" "t'  θ = t'"
    using trm_subst_ident[of t θ] trm_subst_ident[of t' θ]
    by auto
  hence θδ_disj:
      "subst_domain θ  subst_domain δ = {}"
      "subst_domain θ  range_vars δ = {}"
      "subst_domain θ  range_vars θ = {}" 
    using trm_subst_disj mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] apply (blast,blast)
    using Equality.prems(1) unfolding wfconstr_def wfsubst_def by blast
  hence θδ_support: "θ supports " "δ supports "
    by (simp_all add: subst_support_comp_split[OF (θ s δ) supports ])

  have "fv t  fvst (S@Equality a t t'#S')" "fv t'  fvst (S@Equality a t t'#S')" by auto
  hence δ_vars_bound: "subst_domain δ  range_vars δ  fvst (S@Equality a t t'#S')"
    using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] by blast

  have "ikst S set ; [Equality a t t']c "
  proof -
    have "t  δ = t'  δ"
      using MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]]
      by metis
    hence "t  (θ s δ) = t'  (θ s δ)" by (metis θfun_id subst_subst_compose)
    hence "t   = t'  " by (metis σ subst_subst_compose) 
    thus ?thesis by simp
  qed

  have "{}; Sc " "ikst S set ; S'c "
  proof -
    have "(S@S' st δ) st θ = S@S' st δ" "(S@S') st θ = S@S'"
    proof -
      have "subst_domain θ  varsst (S@S') = {}"
        using Equality.prems(1)
        by (fastforce simp add: wfconstr_def simp del: subst_range.simps)
      hence "subst_domain θ  fvst (S@S') = {}" by blast
      hence "subst_domain θ  fvst (S@S' st δ) = {}"
        using θδ_disj(2) subst_sends_strand_fv_to_img[of "S@S'" δ] by blast
      thus "(S@S' st δ) st θ = S@S' st δ" "(S@S') st θ = S@S'"
        using strand_subst_comp ‹subst_domain θ  varsst (S@S') = {} by (blast,blast)
    qed
    moreover have
        "(subst_domain θ  range_vars θ)  bvarsst (S@S') = {}"
        "(subst_domain θ  range_vars θ)  bvarsst (S@S' st δ) = {}"
        "(subst_domain δ  range_vars δ)  bvarsst (S@S') = {}"
      using wf_constr_bvars_disj[OF Equality.prems(1)]
            wf_constr_bvars_disj'[OF Equality.prems(1) δ_vars_bound]
      by auto
    ultimately have "{}; S@S'c "
      using {}; S@S' st δc  σ
            strand_sem_subst(1)[of θ "S@S' st δ" "{}" "δ s σ"]
            strand_sem_subst(2)[of θ "S@S'" "{}" "δ s σ"] 
            strand_sem_subst_subst_idem[of δ "S@S'" "{}" σ]
            mgu_gives_subst_idem[OF Equality.hyps(2)[symmetric]]
      unfolding constr_sem_c_def
      by (metis subst_compose_assoc)
    thus "{}; Sc " "ikst S set ; S'c " by auto
  qed
  
  show " c S@Equality a t t'#S',θ"
    using θδ_support(1) ikst S set ; [Equality a t t']c  {}; Sc  ikst S set ; S'c 
    by (auto simp add: constr_sem_c_def)
qed

theorem LI_soundness:
  assumes "wfconstr S1 θ1" "(S1,θ1) * (S2,θ2)" " c S2, θ2"
  shows " c S1, θ1"
using assms(2,1,3)
proof (induction S2 θ2 rule: rtrancl_induct2)
  case (step Si θi Sj θj) thus ?case
    using LI_preserves_wellformedness[OF (S1, θ1) * (Si, θi) ‹wfconstr S1 θ1]
          LI_soundness_single[OF _ (Si, θi)  (Sj, θj)  c Sj, θj]
          step.IH[OF ‹wfconstr S1 θ1]
    by metis
qed metis
end

subsection ‹Theorem: Completeness of the Lazy Intruder›
context
begin
private lemma LI_completeness_single:
  assumes "wfconstr S1 θ1" " c S1, θ1" "¬simple S1"
  shows "S2 θ2. (S1,θ1)  (S2,θ2)  ( c S2, θ2)"
using not_simple_elim[OF ¬simple S1]
proof -
  { ― ‹In this case S1 isn't simple because it contains an equality constraint,
        so we can simply proceed with the reduction by computing the MGU for the equation›
    assume "S' S'' a t t'. S1 = S'@Equality a t t'#S''  simple S'"
    then obtain S a t t' S' where S1: "S1 = S@Equality a t t'#S'" "simple S" by moura
    hence *: "wfst {} S" " c S, θ1" "θ1 supports " "t   = t'  "
      using  c S1, θ1 ‹wfconstr S1 θ1 wf_eq_fv[of "{}" S t t' S']
            fv_snd_rcv_strand_subset(5)[of S]
      by (auto simp add: constr_sem_c_def wfconstr_def)

    from * have "Unifier  t t'" by simp
    then obtain δ where δ:
        "Some δ = mgu t t'" "subst_idem δ" "subst_domain δ  range_vars δ  fv t  fv t'"
      using mgu_always_unifies mgu_gives_subst_idem mgu_vars_bounded by metis+
    
    have "δ  "
      using mgu_gives_MGU[OF δ(1)[symmetric]]
      by (metis ‹Unifier  t t')
    hence "δ supports " using subst_support_if_mgt_subst_idem[OF _ δ(2)] by metis
    hence "(θ1 s δ) supports " using subst_support_comp θ1 supports  by metis
    
    have "{}; S@S' st δc "
    proof -
      have "subst_domain δ  range_vars δ  fvst S1" using δ(3) S1(1) by auto
      hence "{}; S1 st δc "
        using ‹subst_idem δ δ    c S1, θ1 strand_sem_subst
              wf_constr_bvars_disj'(1)[OF assms(1)]
        unfolding subst_idem_def constr_sem_c_def
        by (metis (no_types) subst_compose_assoc)
      thus "{}; S@S' st δc " using S1(1) by force
    qed
    moreover have "(S@Equality a t t'#S', θ1)  (S@S' st δ, θ1 s δ)"
      using LI_rel.Equality[OF ‹simple S δ(1)] S1 by metis
    ultimately have ?thesis
      using S1(1) (θ1 s δ) supports 
      by (auto simp add: constr_sem_c_def)
  } moreover {
    ― ‹In this case S1 isn't simple because it contains a deduction constraint for a composed
        term, so we must look at how this composed term is derived under the interpretation ℐ›
    assume "S' S'' f T. S1 = S'@Send (Fun f T)#S''  simple S'"
    with assms obtain S f T S' where S1: "S1 = S@Send (Fun f T)#S'" "simple S" by moura
    hence "wfst {} S" " c S, θ1" "θ1 supports "
      using  c S1, θ1 ‹wfconstr S1 θ1
      by (auto simp add: constr_sem_c_def wfconstr_def)
  
    ― ‹Lemma for a common subcase›
    have fun_sat: " c S@(map Send T)@S', θ1" when T: "t. t  set T  ikst S set  c t  "
    proof -
      have "t. t  set T  ikst S set ; [Send t]c " using T by simp
      hence "ikst S set ; map Send Tc " using  c S1, θ1 strand_sem_Send_map by metis
      moreover have "ikst (S@(map Send T)) set ; S'c "
        using  c S1, θ1 S1
        by (auto simp add: constr_sem_c_def)
      ultimately show ?thesis
        using  c S, θ1  c S1, θ1
        by (force simp add: constr_sem_c_def)
    qed
  
    from S1  c S1, θ1 have "ikst S set  c Fun f T  " by (auto simp add: constr_sem_c_def)
    hence ?thesis
    proof cases
      ― ‹Case 1: ℐ(f(T))› has been derived using the AxiomC› rule.›
      case AxiomC
      hence ex_t: "t. t  ikst S  Fun f T   = t  " by auto
      show ?thesis
      proof (cases "T'. Fun f T'  ikst S  Fun f T    Fun f T'  ")
        ― ‹Case 1.1: f(T)› is equal to a variable in the intruder knowledge under ℐ›.
            Hence there must exists a deduction constraint in the simple prefix of the constraint
            in which this variable occurs/"is sent" for the first time. Since this variable itself
            cannot have been derived from the AxiomC› rule (because it must be equal under the
            interpretation to f(T)›, which is by assumption not in the intruder knowledge under
            ℐ›) it must be the case that we can derive it using the ComposeC› rule. Hence we can
            apply the Compose› rule of the lazy intruder to f(T)›.›
        case True
        have "v. Var v  ikst S  Fun f T   =  v"
        proof -
          obtain t where "t  ikst S" "Fun f T   = t  " using ex_t by moura
          thus ?thesis
            using T'. Fun f T'  ikst S  Fun f T    Fun f T'  
            by (cases t) auto
        qed
        hence "v  wfrestrictedvarsst S. Fun f T   =  v"
          using vars_subset_if_in_strand_ik2[of _ S] by fastforce
        then obtain v Spre Ssuf
          where S: "S = Spre@Send (Var v)#Ssuf" "Fun f T   =  v"
                   "¬(w  wfrestrictedvarsst Spre. Fun f T   =  w)"
          using ‹wfst {} S wf_simple_strand_first_Send_var_split[OF _ ‹simple S, of "Fun f T" ]
          by auto
        hence "w. Var w  ikst Spre   v  Var w  " by auto
        moreover have "T'. Fun f T'  ikst Spre  Fun f T    Fun f T'  "
          using T'. Fun f T'  ikst S  Fun f T    Fun f T'   S(1)
          by (meson contra_subsetD ik_append_subset(1))
        hence "g T'. Fun g T'  ikst Spre   v  Fun g T'  " using S(2) by simp
        ultimately have "t  ikst Spre.  v  t  " by (metis term.exhaust)
        hence " v  (ikst Spre) set " by auto
  
        have "ikst Spre set  c  v"
          using S1(1) S(1)  c S1, θ1
          by (auto simp add: constr_sem_c_def)
        hence "ikst Spre set  c Fun f T  " using ‹Fun f T   =  v by metis
        hence "length T = arity f" "public f" "t. t  set T  ikst Spre set  c t  "
          using ‹Fun f T   =  v  v  ikst Spre set 
                intruder_synth.simps[of "ikst Spre set " " v"]
          by auto
        hence *: "t. t  set T  ikst S set  c t  "
          using S(1) by (auto intro: ideduct_synth_mono)
        hence " c S@(map Send T)@S', θ1" by (metis fun_sat)
        moreover have "(S@Send (Fun f T)#S', θ1)  (S@map Send T@S', θ1)"
          by (metis LI_rel.Compose[OF ‹simple S ‹length T = arity f public f])
        ultimately show ?thesis using S1 by auto
      next
        ― ‹Case 1.2: ℐ(f(T))› can be derived from an interpreted composed term in the intruder
            knowledge. Use the Unify› rule on this composed term to further reduce the constraint.›
        case False
        then obtain T' where t: "Fun f T'  ikst S" "Fun f T   = Fun f T'  "
          by auto
        hence "fv (Fun f T')  fvst S1"
          using S1(1) fv_subset_if_in_strand_ik'[OF t(1)]
                fv_snd_rcv_strand_subset(2)[of S]
          by auto
        from t have "Unifier  (Fun f T) (Fun f T')" by simp
        then obtain δ where δ:
            "Some δ = mgu (Fun f T) (Fun f T')" "subst_idem δ"
            "subst_domain δ  range_vars δ  fv (Fun f T)  fv (Fun f T')"
          using mgu_always_unifies mgu_gives_subst_idem mgu_vars_bounded by metis+
        
        have "δ  "
          using mgu_gives_MGU[OF δ(1)[symmetric]]
          by (metis ‹Unifier  (Fun f T) (Fun f T'))
        hence "δ supports " using subst_support_if_mgt_subst_idem[OF _ δ(2)] by metis
        hence "(θ1 s δ) supports " using subst_support_comp θ1 supports  by metis
        
        have "{}; S@S' st δc "
        proof -
          have "subst_domain δ  range_vars δ  fvst S1"
            using δ(3) S1(1) ‹fv (Fun f T')  fvst S1
            unfolding range_vars_alt_def by (fastforce simp del: subst_range.simps)
          hence "{}; S1 st δc "
            using ‹subst_idem δ δ    c S1, θ1 strand_sem_subst
                  wf_constr_bvars_disj'(1)[OF assms(1)]
            unfolding subst_idem_def constr_sem_c_def
            by (metis (no_types) subst_compose_assoc)
          thus "{}; S@S' st δc " using S1(1) by force
        qed
        moreover have "(S@Send (Fun f T)#S', θ1)  (S@S' st δ, θ1 s δ)"
          using LI_rel.Unify[OF ‹simple S t(1) δ(1)] S1 by metis
        ultimately show ?thesis
          using S1(1) (θ1 s δ) supports 
          by (auto simp add: constr_sem_c_def)
      qed
    next
      ― ‹Case 2: ℐ(f(T))› has been derived using the ComposeC› rule.
          Simply use the Compose› rule of the lazy intruder to proceed with the reduction.›
      case (ComposeC T' g)
      hence "f = g" "length T = arity f" "public f"
        and "x. x  set T  ikst S set  c x  "
        by auto
      hence " c S@(map Send T)@S', θ1" using fun_sat by metis
      moreover have "(S1, θ1)  (S@(map Send T)@S', θ1)"
        using S1 LI_rel.Compose[OF ‹simple S ‹length T = arity f public f]
        by metis
      ultimately show ?thesis by metis
    qed
  } moreover have "A B X F. S1 = A@Inequality X F#B  ineq_model  X F"
    using assms(2) by (auto simp add: constr_sem_c_def)
  ultimately show ?thesis using not_simple_elim[OF ¬simple S1] by metis
qed

theorem LI_completeness:
  assumes "wfconstr S1 θ1" " c S1, θ1"
  shows "S2 θ2. (S1,θ1) * (S2,θ2)  simple S2  ( c S2, θ2)"
proof (cases "simple S1")
  case False
  let ?Stuck = "λS2 θ2. ¬(S3 θ3. (S2,θ2)  (S3,θ3)  ( c S3, θ3))"
  let ?Sats = "{((S,θ),(S',θ')). (S,θ)  (S',θ')  ( c S, θ)  ( c S', θ')}"

  have simple_if_stuck:
      "S2 θ2. (S1,θ1) + (S2,θ2);  c S2, θ2; ?Stuck S2 θ2  simple S2"
    using LI_completeness_single
          LI_preserves_wellformedness
          ‹wfconstr S1 θ1
          trancl_into_rtrancl
    by metis

  have base: "b. ((S1,θ1),b)  ?Sats"
    using LI_completeness_single[OF assms False] assms(2)
    by auto

  have *: "S θ S' θ'. ((S,θ),(S',θ'))  ?Sats+  (S,θ) + (S',θ')  ( c S', θ')"
  proof -
    fix S θ S' θ'
    assume "((S,θ),(S',θ'))  ?Sats+"
    thus "(S,θ) + (S',θ')  ( c S', θ')"
      by (induct rule: trancl_induct2) auto
  qed

  have "S2 θ2. ((S1,θ1),(S2,θ2))  ?Sats+  ?Stuck S2 θ2"
  proof (rule ccontr)
    assume "¬(S2 θ2. ((S1,θ1),(S2,θ2))  ?Sats+  ?Stuck S2 θ2)"
    hence sat_not_stuck: "S2 θ2. ((S1,θ1),(S2,θ2))  ?Sats+  ¬?Stuck S2 θ2" by blast

    have "S θ. ((S1,θ1),(S,θ))  ?Sats+  (b. ((S,θ),b)  ?Sats)"
    proof (intro allI impI)
      fix S θ assume a: "((S1,θ1),(S,θ))  ?Sats+"
      have "b. ((S1,θ1),b)  ?Sats+  c. b  c  ((S1,θ1),c)  ?Sats+"
      proof -
        fix b assume in_sat: "((S1,θ1),b)  ?Sats+"
        hence "c. (b,c)  ?Sats" using * sat_not_stuck by (cases b) blast
        thus "c. b  c  ((S1,θ1),c)  ?Sats+"
          using trancl_into_trancl[OF in_sat] by blast
      qed
      hence "S' θ'. (S,θ)  (S',θ')  ((S1,θ1),(S',θ'))  ?Sats+" using a by auto
      then obtain S' θ' where S'θ': "(S,θ)  (S',θ')" "((S1,θ1),(S',θ'))  ?Sats+" by auto
      hence " c S', θ'" using * by blast
      moreover have "(S1, θ1) + (S,θ)" using a trancl_mono by blast
      ultimately have "((S,θ),(S',θ'))  ?Sats" using S'θ'(1) * a by blast
      thus "b. ((S,θ),b)  ?Sats" using S'θ'(2) by blast 
    qed
    hence "f. i::nat. (f i, f (Suc i))  ?Sats"
      using infinite_chain_intro'[OF base] by blast
    moreover have "?Sats  LI_rel+" by auto
    hence "¬(f. i::nat. (f i, f (Suc i))  ?Sats)"
      using LI_no_infinite_chain infinite_chain_mono by blast
    ultimately show False by auto
  qed
  hence "S2 θ2. (S1, θ1) + (S2, θ2)  simple S2  ( c S2, θ2)"
    using simple_if_stuck * by blast
  thus ?thesis by (meson trancl_into_rtrancl)
qed (blast intro:  c S1, θ1)
end


subsection ‹Corollary: Soundness and Completeness as a Single Theorem›
corollary LI_soundness_and_completeness:
  assumes "wfconstr S1 θ1"
  shows " c S1, θ1  (S2 θ2. (S1,θ1) * (S2,θ2)  simple S2  ( c S2, θ2))"
by (metis LI_soundness[OF assms] LI_completeness[OF assms])

end

end

Theory Typed_Model

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Typed_Model.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹The Typed Model›
theory Typed_Model
imports Lazy_Intruder
begin

text ‹Term types›
type_synonym ('f,'v) term_type = "('f,'v) term"

text ‹Constructors for term types›
abbreviation (input) TAtom::"'v  ('f,'v) term_type" where
  "TAtom a  Var a"

abbreviation (input) TComp::"['f, ('f,'v) term_type list]  ('f,'v) term_type" where
  "TComp f T  Fun f T"


text ‹
  The typed model extends the intruder model with a typing function Γ› that assigns types to terms.
›
locale typed_model = intruder_model arity public Ana
  for arity::"'fun  nat"
    and public::"'fun  bool"
    and Ana::"('fun,'var) term  (('fun,'var) term list × ('fun,'var) term list)"
  +
  fixes Γ::"('fun,'var) term  ('fun,'atom::finite) term_type"
  assumes const_type: "c. arity c = 0  a. T. Γ (Fun c T) = TAtom a"
    and fun_type: "f T. arity f > 0  Γ (Fun f T) = TComp f (map Γ T)"
    and infinite_typed_consts: "a. infinite {c. Γ (Fun c []) = TAtom a  public c}"
    and Γ_wf: "t f T. TComp f T  Γ t  arity f > 0"
              "x. wftrm (Γ (Var x))"
    and no_private_funs[simp]: "f. arity f > 0  public f"
begin

subsection ‹Definitions›
text ‹The set of atomic types›
abbreviation "𝔗a  UNIV::('atom set)"

text ‹Well-typed substitutions›
definition wtsubst where
  "wtsubst σ  (v. Γ (Var v) = Γ (σ v))"

text ‹The set of sub-message patterns (SMP)›
inductive_set SMP::"('fun,'var) terms  ('fun,'var) terms" for M where
  MP[intro]: "t  M  t  SMP M"
| Subterm[intro]: "t  SMP M; t'  t  t'  SMP M"
| Substitution[intro]: "t  SMP M; wtsubst δ; wftrms (subst_range δ)  (t  δ)  SMP M"
| Ana[intro]: "t  SMP M; Ana t = (K,T); k  set K  k  SMP M"

text ‹
  Type-flaw resistance for sets:
  Unifiable sub-message patterns must have the same type (unless they are variables)
›
definition tfrset where
  "tfrset M  (s  SMP M - (Var`𝒱). t  SMP M - (Var`𝒱). (δ. Unifier δ s t)  Γ s = Γ t)"

text ‹
  Type-flaw resistance for strand steps:
  - The terms in a satisfiable equality step must have the same types
  - Inequality steps must satisfy the conditions of the "inequality lemma"›
fun tfrstp where
  "tfrstp (Equality a t t') = ((δ. Unifier δ t t')  Γ t = Γ t')"
| "tfrstp (Inequality X F) = (
      (x  fvpairs F - set X. a. Γ (Var x) = TAtom a) 
      (f T. Fun f T  subtermsset (trmspairs F)  T = []  (s  set T. s  Var ` set X)))"
| "tfrstp _ = True"

text ‹
  Type-flaw resistance for strands:
  - The set of terms in strands must be type-flaw resistant
  - The steps of strands must be type-flaw resistant
›
definition tfrst where
  "tfrst S  tfrset (trmsst S)  list_all tfrstp S"


subsection ‹Small Lemmata›
lemma tfrstp_list_all_alt_def:
  "list_all tfrstp S 
    ((a t t'. Equality a t t'  set S  (δ. Unifier δ t t')  Γ t = Γ t') 
    (X F. Inequality X F  set S  
      (x  fvpairs F - set X. a. Γ (Var x) = TAtom a)
     (f T. Fun f T  subtermsset (trmspairs F)  T = []  (s  set T. s  Var ` set X))))"
  (is "?P S  ?Q S")
proof
  show "?P S  ?Q S"
  proof (induction S)
    case (Cons x S) thus ?case by (cases x) auto
  qed simp

  show "?Q S  ?P S"
  proof (induction S)
    case (Cons x S) thus ?case by (cases x) auto
  qed simp
qed


lemma Γ_wf': "wftrm t  wftrm (Γ t)"
proof (induction t)
  case (Fun f T)
  hence *: "arity f = length T" "t. t  set T  wftrm (Γ t)" unfolding wftrm_def by auto
  { assume "arity f = 0" hence ?case using const_type[of f] by auto }
  moreover
  { assume "arity f > 0" hence ?case using fun_type[of f] * by force }
  ultimately show ?case by auto 
qed (metis Γ_wf(2))

lemma fun_type_inv: assumes "Γ t = TComp f T" shows "arity f > 0" "public f"
using Γ_wf(1)[of f T t] assms by simp_all

lemma fun_type_inv_wf: assumes "Γ t = TComp f T" "wftrm t" shows "arity f = length T"
using Γ_wf'[OF assms(2)] assms(1) unfolding wftrm_def by auto

lemma const_type_inv: "Γ (Fun c X) = TAtom a  arity c = 0"
by (rule ccontr, simp add: fun_type)

lemma const_type_inv_wf: assumes "Γ (Fun c X) = TAtom a" and "wftrm (Fun c X)" shows "X = []"
by (metis assms const_type_inv length_0_conv subtermeqI' wftrm_def)

lemma const_type': "c  𝒞. a  𝔗a. X. Γ (Fun c X) = TAtom a" using const_type by simp
lemma fun_type': "f  Σf. X. Γ (Fun f X) = TComp f (map Γ X)" using fun_type by simp

lemma infinite_public_consts[simp]: "infinite {c. public c  arity c = 0}"
proof -
  fix a::'atom
  define A where "A  {c. Γ (Fun c []) = TAtom a  public c}"
  define B where "B  {c. public c  arity c = 0}"

  have "arity c = 0" when c: "c  A" for c
    using c const_type_inv unfolding A_def by blast
  hence "A  B" unfolding A_def B_def by blast
  hence "infinite B"
    using infinite_typed_consts[of a, unfolded A_def[symmetric]]
    by (metis infinite_super)
  thus ?thesis unfolding B_def by blast
qed

lemma infinite_fun_syms[simp]:
  "infinite {c. public c  arity c > 0}  infinite Σf"
  "infinite 𝒞" "infinite 𝒞pub" "infinite (UNIV::'fun set)"
by (metis Σf_unfold finite_Collect_conjI,
    metis infinite_public_consts finite_Collect_conjI,
    use infinite_public_consts 𝒞pub_unfold in force simp add: Collect_conj_eq›,
    metis UNIV_I finite_subset subsetI infinite_public_consts(1))

lemma id_univ_proper_subset[simp]: f  UNIV" "(f. arity f > 0)  𝒞  UNIV"
by (metis finite.emptyI inf_top.right_neutral top.not_eq_extremum disjoint_fun_syms
          infinite_fun_syms(2) inf_commute)
   (metis top.not_eq_extremum UNIV_I const_arity_eq_zero less_irrefl)

lemma exists_fun_notin_funs_term: "f::'fun. f  funs_term t"
by (metis UNIV_eq_I finite_fun_symbols infinite_fun_syms(4))

lemma exists_fun_notin_funs_terms:
  assumes "finite M" shows "f::'fun. f  (funs_term ` M)"
by (metis assms finite_fun_symbols infinite_fun_syms(4) ex_new_if_finite finite_UN)

lemma exists_notin_funsst: "f. f  funsst (S::('fun,'var) strand)"
by (metis UNIV_eq_I finite_funsst infinite_fun_syms(4))

lemma infinite_typed_consts': "infinite {c. Γ (Fun c []) = TAtom a  public c  arity c = 0}"
proof -
  { fix c assume "Γ (Fun c []) = TAtom a" "public c"
    hence "arity c = 0" using const_type[of c] fun_type[of c "[]"] by auto
  } hence "{c. Γ (Fun c []) = TAtom a  public c  arity c = 0} =
           {c. Γ (Fun c []) = TAtom a  public c}"
    by auto
  thus "infinite {c. Γ (Fun c []) = TAtom a  public c  arity c = 0}"
    using infinite_typed_consts[of a] by metis
qed

lemma atypes_inhabited: "c. Γ (Fun c []) = TAtom a  wftrm (Fun c [])  public c  arity c = 0"
proof -
  obtain c where "Γ (Fun c []) = TAtom a" "public c" "arity c = 0"
    using infinite_typed_consts'(1)[of a] not_finite_existsD by blast
  thus ?thesis using const_type_inv[OF Γ (Fun c []) = TAtom a] unfolding wftrm_def by auto
qed

lemma atype_ground_term_ex: "t. fv t = {}  Γ t = TAtom a  wftrm t"
using atypes_inhabited[of a] by force

lemma fun_type_id_eq: "Γ (Fun f X) = TComp g Y  f = g"
by (metis const_type fun_type neq0_conv "term.inject"(2) "term.simps"(4))

lemma fun_type_length_eq: "Γ (Fun f X) = TComp g Y  length X = length Y"
by (metis fun_type fun_type_id_eq fun_type_inv(1) length_map term.inject(2))

lemma type_ground_inhabited: "t'. fv t' = {}  Γ t = Γ t'"
proof -
  { fix τ::"('fun, 'atom) term_type" assume "f T. Fun f T  τ  0 < arity f"
    hence "t'. fv t' = {}  τ = Γ t'"
    proof (induction τ)
      case (Fun f T)
      hence "arity f > 0" by auto
    
      from Fun.IH Fun.prems(1) have "Y. map Γ Y = T  (x  set Y. fv x = {})"
      proof (induction T)
        case (Cons x X)
        hence "g Y. Fun g Y  Fun f X  0 < arity g" by auto
        hence "Y. map Γ Y = X  (xset Y. fv x = {})" using Cons by auto
        moreover have "t'. fv t' = {}  x = Γ t'" using Cons by auto
        ultimately obtain y Y where
            "fv y = {}" "Γ y = x" "map Γ Y = X" "xset Y. fv x = {}" 
          using Cons by moura
        hence "map Γ (y#Y) = x#X  (xset (y#Y). fv x = {})" by auto
        thus ?case by meson 
      qed simp
      then obtain Y where "map Γ Y = T" "x  set Y. fv x = {}" by metis
      hence "fv (Fun f Y) = {}" "Γ (Fun f Y) = TComp f T" using fun_type[OF arity f > 0] by auto
      thus ?case by (metis exI[of "λt. fv t = {}  Γ t = TComp f T" "Fun f Y"])
    qed (metis atype_ground_term_ex)
  }
  thus ?thesis by (metis Γ_wf(1))
qed

lemma type_wfttype_inhabited:
  assumes "f T. Fun f T  τ  0 < arity f" "wftrm τ"
  shows "t. Γ t = τ  wftrm t"
using assms
proof (induction τ)
  case (Fun f Y)
  have IH: "t. Γ t = y  wftrm t" when y: "y  set Y " for y
  proof -
    have "wftrm y"
      using Fun y unfolding wftrm_def
      by (metis Fun_param_is_subterm term.le_less_trans) 
    moreover have "Fun g Z  y  0 < arity g" for g Z
      using Fun y by auto
    ultimately show ?thesis using Fun.IH[OF y] by auto
  qed

  from Fun have "arity f = length Y" "arity f > 0" unfolding wftrm_def by force+
  moreover from IH have "X. map Γ X = Y  (x  set X. wftrm x)"
    by (induct Y, simp_all, metis list.simps(9) set_ConsD)
  ultimately show ?case by (metis fun_type length_map wf_trmI)
qed (use atypes_inhabited wftrm_def in blast)

lemma type_pgwt_inhabited: "wftrm t  t'. Γ t = Γ t'  public_ground_wf_term t'"
proof -
  assume "wftrm t"
  { fix τ assume "Γ t = τ"
    hence "t'. Γ t = Γ t'  public_ground_wf_term t'" using ‹wftrm t
    proof (induction τ arbitrary: t)
      case (Var a t)
      then obtain c where "Γ t = Γ (Fun c [])" "arity c = 0" "public c"
        using const_type_inv[of _ "[]" a] infinite_typed_consts(1)[of a]  not_finite_existsD
        by force
      thus ?case using PGWT[OF public c, of "[]"] by auto
    next
      case (Fun f Y t)
      have *: "arity f > 0" "public f" "arity f = length Y"
        using fun_type_inv[OF Γ t = TComp f Y] fun_type_inv_wf[OF Γ t = TComp f Y ‹wftrm t]
        by auto
      have "y. y  set Y  t'. y = Γ t'  public_ground_wf_term t'"
        using Fun.prems(1) Fun.IH Γ_wf(1)[of _ _ t] Γ_wf'[OF ‹wftrm t] type_wfttype_inhabited
        by (metis Fun_param_is_subterm term.order_trans wf_trm_subtermeq) 
      hence "X. map Γ X = Y  (x  set X. public_ground_wf_term x)"
        by (induct Y, simp_all, metis list.simps(9) set_ConsD)
      then obtain X where X: "map Γ X = Y" "x. x  set X  public_ground_wf_term x" by moura
      hence "arity f = length X" using *(3) by auto
      have "Γ t = Γ (Fun f X)" "public_ground_wf_term (Fun f X)"
        using fun_type[OF *(1), of X] Fun.prems(1) X(1) apply simp
        using PGWT[OF *(2) arity f = length X X(2)] by metis
      thus ?case by metis
    qed
  }
  thus ?thesis using ‹wftrm t by auto
qed

lemma pgwt_type_map: 
  assumes "public_ground_wf_term t"
  shows "Γ t = TAtom a  f. t = Fun f []" "Γ t = TComp g Y  X. t = Fun g X  map Γ X = Y"
proof -
  let ?A = "Γ t = TAtom a  (f. t = Fun f [])"
  let ?B = "Γ t = TComp g Y  (X. t = Fun g X  map Γ X = Y)"
  have "?A  ?B"
  proof (cases "Γ t")
    case (Var a)
    obtain f X where "t = Fun f X" "arity f = length X"
      using pgwt_fun[OF assms(1)] pgwt_arity[OF assms(1)] by fastforce+
    thus ?thesis using const_type_inv Γ t = TAtom a by auto
  next
    case (Fun g Y)
    obtain f X where *: "t = Fun f X" using pgwt_fun[OF assms(1)] by force
    hence "f = g" "map Γ X = Y"
      using fun_type_id_eq Γ t = TComp g Y fun_type[OF fun_type_inv(1)[OF Γ t = TComp g Y]]
      by fastforce+
    thus ?thesis using *(1) Γ t = TComp g Y by auto 
  qed
  thus "Γ t = TAtom a  f. t = Fun f []" "Γ t = TComp g Y  X. t = Fun g X  map Γ X = Y"
    by auto
qed 

lemma wt_subst_Var[simp]: "wtsubst Var" by (metis wtsubst_def)

lemma wt_subst_trm: "(v. v  fv t  Γ (Var v) = Γ (θ v))  Γ t = Γ (t  θ)"
proof (induction t)
  case (Fun f X)
  hence *: "x. x  set X  Γ x = Γ (x  θ)" by auto
  show ?case
  proof (cases "f  Σf")
    case True
    hence "X. Γ (Fun f X) = TComp f (map Γ X)" using fun_type' by auto
    thus ?thesis using * by auto
  next
    case False
    hence "a  𝔗a. X. Γ (Fun f X) = TAtom a" using const_type' by auto
    thus ?thesis by auto
  qed
qed auto

lemma wt_subst_trm': "wtsubst σ; Γ s = Γ t  Γ (s  σ) = Γ (t  σ)"
by (metis wt_subst_trm wtsubst_def)

lemma wt_subst_trm'': "wtsubst σ  Γ t = Γ (t  σ)"
by (metis wt_subst_trm wtsubst_def)

lemma wt_subst_compose:
  assumes "wtsubst θ" "wtsubst δ" shows "wtsubst (θ s δ)"
proof -
  have "v. Γ (θ v) = Γ (θ v  δ)" using wt_subst_trm ‹wtsubst δ unfolding wtsubst_def by metis
  moreover have "v. Γ (Var v) = Γ (θ v)" using ‹wtsubst θ unfolding wtsubst_def by metis
  ultimately have "v. Γ (Var v) = Γ (θ v  δ)" by metis
  thus ?thesis unfolding wtsubst_def subst_compose_def by metis
qed

lemma wt_subst_TAtom_Var_cases:
  assumes θ: "wtsubst θ" "wftrms (subst_range θ)"
  and x: "Γ (Var x) = TAtom a"
  shows "(y. θ x = Var y)  (c. θ x = Fun c [])"
proof (cases "(y. θ x = Var y)")
  case False
  then obtain c T where c: "θ x = Fun c T"
    by (cases "θ x") simp_all
  hence "wftrm (Fun c T)"
    using θ(2) by fastforce
  hence "T = []"
    using const_type_inv_wf[of c T a] x c wt_subst_trm''[OF θ(1), of "Var x"]
    by fastforce
  thus ?thesis
    using c by blast
qed simp

lemma wt_subst_TAtom_fv:
  assumes θ: "wtsubst θ" "x. wftrm (θ x)"
  and "x  fv t - X. a. Γ (Var x) = TAtom a"
  shows "x  fv (t  θ) - fvset (θ ` X). a. Γ (Var x) = TAtom a"
using assms(3)
proof (induction t)
  case (Var x) thus ?case
  proof (cases "x  X")
    case False
    with Var obtain a where "Γ (Var x) = TAtom a" by moura
    hence *: "Γ (θ x) = TAtom a" "wftrm (θ x)" using θ unfolding wtsubst_def by auto
    show ?thesis
    proof (cases "θ x")
      case (Var y) thus ?thesis using * by auto
    next
      case (Fun f T)
      hence "T = []" using * const_type_inv[of f T a] unfolding wftrm_def by auto
      thus ?thesis using Fun by auto
    qed
  qed auto
qed fastforce

lemma wt_subst_TAtom_subterms_subst:
  assumes "wtsubst θ" "x  fv t. a. Γ (Var x) = TAtom a" "wftrms (θ ` fv t)"
  shows "subterms (t  θ) = subterms t set θ"
using assms(2,3)
proof (induction t)
  case (Var x)
  obtain a where a: "Γ (Var x) = TAtom a" using Var.prems(1) by moura
  hence "Γ (θ x) = TAtom a" using wt_subst_trm''[OF assms(1), of "Var x"] by simp
  hence "(y. θ x = Var y)  (c. θ x = Fun c [])"
    using const_type_inv_wf Var.prems(2) by (cases "θ x") auto
  thus ?case by auto
next
  case (Fun f T)
  have "subterms (t  θ) = subterms t set θ" when "t  set T" for t
    using that Fun.prems(1,2) Fun.IH[OF that]
    by auto
  thus ?case by auto
qed

lemma wt_subst_TAtom_subterms_set_subst: 
  assumes "wtsubst θ" "x  fvset M. a. Γ (Var x) = TAtom a" "wftrms (θ ` fvset M)"
  shows "subtermsset (M set θ) = subtermsset M set θ"
proof
  show "subtermsset (M set θ)  subtermsset M set θ"
  proof
    fix t assume "t  subtermsset (M set θ)"
    then obtain s where s: "s  M" "t  subterms (s  θ)" by auto
    thus "t  subtermsset M set θ"
      using assms(2,3) wt_subst_TAtom_subterms_subst[OF assms(1), of s]
      by auto
  qed

  show "subtermsset M set θ  subtermsset (M set θ)"
  proof
    fix t assume "t  subtermsset M set θ"
    then obtain s where s: "s  M" "t  subterms s set θ" by auto
    thus "t  subtermsset (M set θ)"
      using assms(2,3) wt_subst_TAtom_subterms_subst[OF assms(1), of s]
      by auto
  qed
qed

lemma wt_subst_subst_upd:
  assumes "wtsubst θ"
    and "Γ (Var x) = Γ t"
  shows "wtsubst (θ(x := t))"
using assms unfolding wtsubst_def
by (metis fun_upd_other fun_upd_same)

lemma wt_subst_const_fv_type_eq:
  assumes "x  fv t. a. Γ (Var x) = TAtom a"
    and δ: "wtsubst δ" "wftrms (subst_range δ)"
  shows "x  fv (t  δ). y  fv t. Γ (Var x) = Γ (Var y)"
using assms(1)
proof (induction t)
  case (Var x)
  then obtain a where a: "Γ (Var x) = TAtom a" by moura
  show ?case
  proof (cases "δ x")
    case (Fun f T)
    hence "wftrm (Fun f T)" "Γ (Fun f T) = TAtom a"
      using a wt_subst_trm''[OF δ(1), of "Var x"] δ(2) by fastforce+
    thus ?thesis using const_type_inv_wf Fun by fastforce
  qed (use a wt_subst_trm''[OF δ(1), of "Var x"] in simp)
qed fastforce

lemma TComp_term_cases:
  assumes "wftrm t" "Γ t = TComp f T"
  shows "(v. t = Var v)  (T'. t = Fun f T'  T = map Γ T'  T'  [])"
proof (cases "v. t = Var v")
  case False
  then obtain T' where T': "t = Fun f T'" "T = map Γ T'"
    using assms fun_type[OF fun_type_inv(1)[OF assms(2)]] fun_type_id_eq
    by (cases t) force+
  thus ?thesis using assms fun_type_inv(1) fun_type_inv_wf by fastforce
qed metis

lemma TAtom_term_cases:
  assumes "wftrm t" "Γ t = TAtom τ"
  shows "(v. t = Var v)  (f. t = Fun f [])"
using assms const_type_inv unfolding wftrm_def by (cases t) auto

lemma subtermeq_imp_subtermtypeeq:
  assumes "wftrm t" "s  t"
  shows "Γ s  Γ t"
using assms(2,1)
proof (induction t)
  case (Fun f T) thus ?case
  proof (cases "s = Fun f T")
    case False
    then obtain x where x: "x  set T" "s  x" using Fun.prems(1) by auto
    hence "wftrm x" using wf_trm_subtermeq[OF Fun.prems(2)] Fun_param_is_subterm[of _ T f] by auto
    hence "Γ s  Γ x" using Fun.IH[OF x] by simp
    moreover have "arity f > 0" using x fun_type_inv_wf Fun.prems
      by (metis length_pos_if_in_set term.order_refl wftrm_def)
    ultimately show ?thesis using x Fun.prems fun_type[of f T] by auto
  qed simp
qed simp

lemma subterm_funs_term_in_type:
  assumes "wftrm t" "Fun f T  t" "Γ (Fun f T) = TComp f (map Γ T)"
  shows "f  funs_term (Γ t)"
using assms(2,1,3)
proof (induction t)
  case (Fun f' T')
  hence [simp]: "wftrm (Fun f T)" by (metis wf_trm_subtermeq)
  { fix a assume τ: "Γ (Fun f' T') = TAtom a"
    hence "Fun f T = Fun f' T'" using Fun TAtom_term_cases subtermeq_Var_const by metis
    hence False using Fun.prems(3) τ by simp
  }
  moreover
  { fix g S assume τ: "Γ (Fun f' T') = TComp g S"
    hence "g = f'" "S = map Γ T'"
      using Fun.prems(2) fun_type_id_eq[OF τ] fun_type[OF fun_type_inv(1)[OF τ]]
      by auto
    hence τ': "Γ (Fun f' T') = TComp f' (map Γ T')" using τ by auto
    hence "g  funs_term (Γ (Fun f' T'))" using τ by auto
    moreover {
      assume "Fun f T  Fun f' T'"
      then obtain x where "x  set T'" "Fun f T  x" using Fun.prems(1) by auto
      hence "f  funs_term (Γ x)"
        using Fun.IH[OF _ _ _ Fun.prems(3), of x] wf_trm_subtermeq[OF ‹wftrm (Fun f' T'), of x]
        by force
      moreover have "Γ x  set (map Γ T')" using τ' x  set T' by auto
      ultimately have "f  funs_term (Γ (Fun f' T'))" using τ' by auto
    }
    ultimately have ?case by (cases "Fun f T = Fun f' T'") (auto simp add: g = f')
  }
  ultimately show ?case by (cases "Γ (Fun f' T')") auto
qed simp

lemma wt_subst_fv_termtype_subterm:
  assumes "x  fv (θ y)"
    and "wtsubst θ"
    and "wftrm (θ y)"
  shows "Γ (Var x)  Γ (Var y)"
using subtermeq_imp_subtermtypeeq[OF assms(3) var_is_subterm[OF assms(1)]]
      wt_subst_trm''[OF assms(2), of "Var y"]
by auto

lemma wt_subst_fvset_termtype_subterm:
  assumes "x  fvset (θ ` Y)"
    and "wtsubst θ"
    and "wftrms (subst_range θ)"
  shows "y  Y. Γ (Var x)  Γ (Var y)"
using wt_subst_fv_termtype_subterm[OF _ assms(2), of x] assms(1,3)
by fastforce

lemma funs_term_type_iff:
  assumes t: "wftrm t"
    and f: "arity f > 0"
  shows "f  funs_term (Γ t)  (f  funs_term t  (x  fv t. f  funs_term (Γ (Var x))))"
    (is "?P t  ?Q t")
using t
proof (induction t)
  case (Fun g T)
  hence IH: "?P s  ?Q s" when "s  set T" for s
    using that wf_trm_subterm[OF _ Fun_param_is_subterm]
    by blast
  have 0: "arity g = length T" using Fun.prems unfolding wftrm_def by auto
  show ?case
  proof (cases "f = g")
    case True thus ?thesis using fun_type[OF f] by simp
  next
    case False
    have "?P (Fun g T)  (s  set T. ?P s)"
    proof
      assume *: "?P (Fun g T)"
      hence "Γ (Fun g T) = TComp g (map Γ T)"
        using const_type[of g] fun_type[of g] by force
      thus "s  set T. ?P s" using False * by force
    next
      assume *: "s  set T. ?P s"
      hence "Γ (Fun g T) = TComp g (map Γ T)"
        using 0 const_type[of g] fun_type[of g] by force
      thus "?P (Fun g T)" using False * by force
    qed
    thus ?thesis using False f IH by auto
  qed
qed simp

lemma funs_term_type_iff':
  assumes M: "wftrms M"
    and f: "arity f > 0"
  shows "f  (funs_term ` Γ ` M) 
        (f  (funs_term ` M)  (x  fvset M. f  funs_term (Γ (Var x))))" (is "?A  ?B")
proof
  assume ?A
  then obtain t where "t  M" "wftrm t" "f  funs_term (Γ t)" using M by moura
  thus ?B using funs_term_type_iff[OF _ f, of t] by auto
next
  assume ?B
  then obtain t where "t  M" "wftrm t" "f  funs_term t  (x  fv t. f  funs_term (Γ (Var x)))"
    using M by auto
  thus ?A using funs_term_type_iff[OF _ f, of t] by blast
qed

lemma Ana_subterm_type:
  assumes "Ana t = (K,M)"
    and "wftrm t"
    and "m  set M"
  shows "Γ m  Γ t"
proof -
  have "m  t" using Ana_subterm[OF assms(1)] assms(3) by auto
  thus ?thesis using subtermeq_imp_subtermtypeeq[OF assms(2)] by simp
qed

lemma wf_trm_TAtom_subterms:
  assumes "wftrm t" "Γ t = TAtom τ"
  shows "subterms t = {t}"
using assms const_type_inv unfolding wftrm_def by (cases t) force+

lemma wf_trm_TComp_subterm:
  assumes "wftrm s" "t  s"
  obtains f T where "Γ s = TComp f T"
proof (cases s)
  case (Var x) thus ?thesis using t  s by simp
next
  case (Fun g S)
  hence "length S > 0" using assms Fun_subterm_inside_params[of t g S] by auto
  hence "arity g > 0" by (metis ‹wftrm s s = Fun g S term.order_refl wftrm_def) 
  thus ?thesis using fun_type s = Fun g S that by auto
qed

lemma SMP_empty[simp]: "SMP {} = {}"
proof (rule ccontr)
  assume "SMP {}  {}"
  then obtain t where "t  SMP {}" by auto
  thus False by (induct t rule: SMP.induct) auto
qed

lemma SMP_I:
  assumes "s  M" "wtsubst δ" "t  s  δ" "v. wftrm (δ v)"
  shows "t  SMP M"
using SMP.Substitution[OF SMP.MP[OF assms(1)] assms(2)] SMP.Subterm[of "s  δ" M t] assms(3,4)
by (cases "t = s  δ") simp_all

lemma SMP_wf_trm:
  assumes "t  SMP M" "wftrms M"
  shows "wftrm t"
using assms(1)
by (induct t rule: SMP.induct)
   (use assms(2) in blast,
    use wf_trm_subtermeq in blast,
    use wf_trm_subst in blast,
    use Ana_keys_wf' in blast)

lemma SMP_ikI[intro]: "t  ikst S  t  SMP (trmsst S)" by force

lemma MP_setI[intro]: "x  set S  trmsstp x  trmsst S" by force

lemma SMP_setI[intro]: "x  set S  trmsstp x  SMP (trmsst S)" by force

lemma SMP_subset_I:
  assumes M: "t  M. s δ. s  N  wtsubst δ  wftrms (subst_range δ)  t = s  δ"
  shows "SMP M  SMP N"
proof
  fix t show "t  SMP M  t  SMP N"
  proof (induction t rule: SMP.induct)
    case (MP t)
    then obtain s δ where s: "s  N" "wtsubst δ" "wftrms (subst_range δ)" "t = s  δ"
      using M by moura
    show ?case using SMP_I[OF s(1,2), of "s  δ"] s(3,4) wf_trm_subst_range_iff by fast
  qed (auto intro!: SMP.Substitution[of _ N])
qed

lemma SMP_union: "SMP (A  B) = SMP A  SMP B"
proof
  show "SMP (A  B)  SMP A  SMP B"
  proof
    fix t assume "t  SMP (A  B)"
    thus "t  SMP A  SMP B" by (induct rule: SMP.induct) blast+
  qed

  { fix t assume "t  SMP A" hence "t  SMP (A  B)" by (induct rule: SMP.induct) blast+ }
  moreover { fix t assume "t  SMP B" hence "t  SMP (A  B)" by (induct rule: SMP.induct) blast+ }
  ultimately show "SMP A  SMP B  SMP (A  B)" by blast
qed

lemma SMP_append[simp]: "SMP (trmsst (S@S')) = SMP (trmsst S)  SMP (trmsst S')" (is "?A = ?B")
using SMP_union by simp

lemma SMP_mono: "A  B  SMP A  SMP B"
proof -
  assume "A  B"
  then obtain C where "B = A  C" by moura
  thus "SMP A  SMP B" by (simp add: SMP_union)
qed

lemma SMP_Union: "SMP (m  M. f m) = (m  M. SMP (f m))"
proof
  show "SMP (mM. f m)  (mM. SMP (f m))"
  proof
    fix t assume "t  SMP (mM. f m)"
    thus "t  (mM. SMP (f m))" by (induct t rule: SMP.induct) force+
  qed
  show "(mM. SMP (f m))  SMP (mM. f m)"
  proof
    fix t assume "t  (mM. SMP (f m))"
    then obtain m where "m  M" "t  SMP (f m)" by moura
    thus "t  SMP (mM. f m)" using SMP_mono[of "f m" "mM. f m"] by auto
  qed
qed

lemma SMP_singleton_ex:
  "t  SMP M  (m  M. t  SMP {m})"
  "m  M  t  SMP {m}  t  SMP M"
using SMP_Union[of "λt. {t}" M] by auto

lemma SMP_Cons: "SMP (trmsst (x#S)) = SMP (trmsst [x])  SMP (trmsst S)"
using SMP_append[of "[x]" S] by auto

lemma SMP_Nil[simp]: "SMP (trmsst []) = {}" 
proof -
  { fix t assume "t  SMP (trmsst [])" hence False by induct auto }
  thus ?thesis by blast
qed

lemma SMP_subset_union_eq: assumes "M  SMP N" shows "SMP N = SMP (M  N)"
proof -
  { fix t assume "t  SMP (M  N)" hence "t  SMP N"
      using assms by (induction rule: SMP.induct) blast+
  }
  thus ?thesis using SMP_union by auto
qed

lemma SMP_subterms_subset: "subtermsset M  SMP M"
proof
  fix t assume "t  subtermsset M"
  then obtain m where "m  M" "t  m" by auto
  thus "t  SMP M" using SMP_I[of _ _ Var] by auto
qed

lemma SMP_SMP_subset: "N  SMP M  SMP N  SMP M"
by (metis SMP_mono SMP_subset_union_eq Un_commute Un_upper2)

lemma wt_subst_rm_vars: "wtsubst δ  wtsubst (rm_vars X δ)"
using rm_vars_dom unfolding wtsubst_def by auto

lemma wt_subst_SMP_subset:
  assumes "trmsst S  SMP S'" "wtsubst δ" "wftrms (subst_range δ)"
  shows "trmsst (S st δ)  SMP S'"
proof
  fix t assume *: "t  trmsst (S st δ)"
  show "t  SMP S'" using trm_strand_subst_cong(2)[OF *]
  proof
    assume "t'. t = t'  δ  t'  trmsst S"
    thus "t  SMP S'" using assms SMP.Substitution by auto
  next
    assume "X F. Inequality X F  set S  (t'trmspairs F. t = t'  rm_vars (set X) δ)"
    then obtain X F t' where **:
        "Inequality X F  set S" "t'trmspairs F" "t = t'  rm_vars (set X) δ"
      by force
    then obtain s where s: "s  trmsstp (Inequality X F)" "t = s  rm_vars (set X) δ" by moura
    hence "s  SMP (trmsst S)" using **(1) by force
    hence "t  SMP (trmsst S)"
      using SMP.Substitution[OF _ wt_subst_rm_vars[OF assms(2)] wf_trms_subst_rm_vars'[OF assms(3)]]
      unfolding s(2) by blast
    thus "t  SMP S'" by (metis SMP_union SMP_subset_union_eq UnCI assms(1))
  qed
qed

lemma MP_subset_SMP: "(trmsstp ` set S)  SMP (trmsst S)" "trmsst S  SMP (trmsst S)" "M  SMP M"
by auto

lemma SMP_fun_map_snd_subset: "SMP (trmsst (map Send X))  SMP (trmsst [Send (Fun f X)])"
proof
  fix t assume "t  SMP (trmsst (map Send X))" thus "t  SMP (trmsst [Send (Fun f X)])"
  proof (induction t rule: SMP.induct)
    case (MP t)
    hence "t  set X" by auto
    hence "t  Fun f X" by (metis subtermI')
    thus ?case using SMP.Subterm[of "Fun f X" "trmsst [Send (Fun f X)]" t] using SMP.MP by auto
  qed blast+
qed

lemma SMP_wt_subst_subset:
  assumes "t  SMP (M set )" "wtsubst " "wftrms (subst_range )"
  shows "t  SMP M"
using assms wf_trm_subst_range_iff[of ] by (induct t rule: SMP.induct) blast+

lemma SMP_wt_instances_subset:
  assumes "t  M. s  N. δ. t = s  δ  wtsubst δ  wftrms (subst_range δ)"
    and "t  SMP M"
  shows "t  SMP N"
proof -
  obtain m where m: "m  M" "t  SMP {m}" using SMP_singleton_ex(1)[OF assms(2)] by blast
  then obtain n δ where n: "n  N" "m = n  δ" "wtsubst δ" "wftrms (subst_range δ)"
    using assms(1) by fast

  have "t  SMP (N set δ)" using n(1,2) SMP_singleton_ex(2)[of m "N set δ", OF _ m(2)] by fast
  thus ?thesis using SMP_wt_subst_subset[OF _ n(3,4)] by blast
qed

lemma SMP_consts:
  assumes "t  M. c. t = Fun c []"
    and "t  M. Ana t = ([], [])"
  shows "SMP M = M"
proof
  show "SMP M  M"
  proof
    fix t show "t  SMP M  t  M"
      apply (induction t rule: SMP.induct)
      by (use assms in auto)
  qed
qed auto

lemma SMP_subterms_eq:
  "SMP (subtermsset M) = SMP M"
proof
  show "SMP M  SMP (subtermsset M)" using SMP_mono[of M "subtermsset M"] by blast
  show "SMP (subtermsset M)  SMP M"
  proof
    fix t show "t  SMP (subtermsset M)  t  SMP M" by (induction t rule: SMP.induct) blast+
  qed
qed

lemma SMP_funs_term:
  assumes t: "t  SMP M" "f  funs_term t  (x  fv t. f  funs_term (Γ (Var x)))"
    and f: "arity f > 0"
    and M: "wftrms M"
    and Ana_f: "s K T. Ana s = (K,T)  f  (funs_term ` set K)  f  funs_term s"
  shows "f  (funs_term ` M)  (x  fvset M. f  funs_term (Γ (Var x)))"
using t
proof (induction t rule: SMP.induct)
  case (Subterm t t')
  thus ?case by (metis UN_I vars_iff_subtermeq funs_term_subterms_eq(1) term.order_trans)
next
  case (Substitution t δ)
  show ?case
    using M SMP_wf_trm[OF Substitution.hyps(1)] wf_trm_subst[of δ t, OF Substitution.hyps(3)]
          funs_term_type_iff[OF _ f] wt_subst_trm''[OF Substitution.hyps(2), of t]
          Substitution.prems Substitution.IH
    by metis
next
  case (Ana t K T t')
  thus ?case
    using Ana_f[OF Ana.hyps(2)] Ana_keys_fv[OF Ana.hyps(2)]
    by fastforce
qed auto

lemma id_type_eq:
  assumes "Γ (Fun f X) = Γ (Fun g Y)"
  shows "f  𝒞  g  𝒞" "f  Σf  g  Σf"
using assms const_type' fun_type' id_union_univ(1)
by (metis UNIV_I UnE "term.distinct"(1))+

lemma fun_type_arg_cong:
  assumes "f  Σf" "g  Σf" "Γ (Fun f (x#X)) = Γ (Fun g (y#Y))"
  shows "Γ x = Γ y" "Γ (Fun f X) = Γ (Fun g Y)"
using assms fun_type' by auto

lemma fun_type_arg_cong':
  assumes "f  Σf" "g  Σf" "Γ (Fun f (X@x#X')) = Γ (Fun g (Y@y#Y'))" "length X = length Y"
  shows "Γ x = Γ y"
using assms
proof (induction X arbitrary: Y)
  case Nil thus ?case using fun_type_arg_cong(1)[of f g x X' y Y'] by auto
next
  case (Cons x' X Y'')
  then obtain y' Y where "Y'' = y'#Y" by (metis length_Suc_conv)
  hence "Γ (Fun f (X@x#X')) = Γ (Fun g (Y@y#Y'))" "length X = length Y"
    using Cons.prems(3,4) fun_type_arg_cong(2)[OF Cons.prems(1,2), of x' "X@x#X'"] by auto
  thus ?thesis using Cons.IH[OF Cons.prems(1,2)] by auto
qed

lemma fun_type_param_idx: "Γ (Fun f T) = Fun g S  i < length T  Γ (T ! i) = S ! i"
by (metis fun_type fun_type_id_eq fun_type_inv(1) nth_map term.inject(2))

lemma fun_type_param_ex:
  assumes "Γ (Fun f T) = Fun g (map Γ S)" "t  set S"
  shows "s  set T. Γ s = Γ t"
using fun_type_length_eq[OF assms(1)] length_map[of Γ S] assms(2)
      fun_type_param_idx[OF assms(1)] nth_map in_set_conv_nth
by metis

lemma tfr_stp_all_split:
  "list_all tfrstp (x#S)  list_all tfrstp [x]"
  "list_all tfrstp (x#S)  list_all tfrstp S"
  "list_all tfrstp (S@S')  list_all tfrstp S"
  "list_all tfrstp (S@S')  list_all tfrstp S'"
  "list_all tfrstp (S@x#S')  list_all tfrstp (S@S')"
by fastforce+

lemma tfr_stp_all_append:
  assumes "list_all tfrstp S" "list_all tfrstp S'"
  shows "list_all tfrstp (S@S')"
using assms by fastforce

lemma tfr_stp_all_wt_subst_apply:
  assumes "list_all tfrstp S"
    and θ: "wtsubst θ" "wftrms (subst_range θ)"
           "bvarsst S  range_vars θ = {}"
  shows "list_all tfrstp (S st θ)"
using assms(1,4)
proof (induction S)
  case (Cons x S)
  hence IH: "list_all tfrstp (S st θ)"
    using tfr_stp_all_split(2)[of x S]
    unfolding range_vars_alt_def by fastforce
  thus ?case
  proof (cases x)
    case (Equality a t t')
    hence "(δ. Unifier δ t t')  Γ t = Γ t'" using Cons.prems by auto
    hence "(δ. Unifier δ (t  θ) (t'  θ))  Γ (t  θ) = Γ (t'  θ)"
      by (metis Unifier_comp' wt_subst_trm'[OF assms(2)])
    moreover have "(x#S) st θ = Equality a (t  θ) (t'  θ)#(S st θ)"
      using x = Equality a t t' by auto
    ultimately show ?thesis using IH by auto
  next
    case (Inequality X F)
    let  = "rm_vars (set X) θ"
    let ?G = "F pairs "

    let ?P = "λF X. x  fvpairs F - set X. a. Γ (Var x) = TAtom a"
    let ?Q = "λF X.
      f T. Fun f T  subtermsset (trmspairs F)  T = []  (s  set T. s  Var ` set X)"

    have 0: "set X  range_vars  = {}"
      using Cons.prems(2) Inequality rm_vars_img_subset[of "set X"]
      by (auto simp add: subst_domain_def range_vars_alt_def)

    have 1: "?P F X  ?Q F X" using Inequality Cons.prems by simp

    have 2: "fvset ( ` set X) = set X" by auto

    have "?P ?G X" when "?P F X" using that
    proof (induction F)
      case (Cons g G)
      obtain t t' where g: "g = (t,t')" by (metis surj_pair)
      
      have "x  (fv (t  )  fv (t'  )) - set X. a. Γ (Var x) = Var a"
      proof -
        have *: "x  fv t - set X. a. Γ (Var x) = Var a"
               "x  fv t' - set X. a. Γ (Var x) = Var a"
          using g Cons.prems by simp_all

        have **: "x. wftrm ( x)"
          using θ(2) wf_trm_subst_range_iff[of θ] wf_trm_subst_rm_vars'[of θ _ "set X"] by simp

        show ?thesis
          using wt_subst_TAtom_fv[OF wt_subst_rm_vars[OF θ(1)] ** *(1)]
                wt_subst_TAtom_fv[OF wt_subst_rm_vars[OF θ(1)] ** *(2)]
                wt_subst_trm'[OF wt_subst_rm_vars[OF θ(1), of "set X"]] 2
          by blast
      qed
      moreover have "xfvpairs (G pairs ) - set X. a. Γ (Var x) = Var a"
        using Cons by auto
      ultimately show ?case using g by (auto simp add: subst_apply_pairs_def)
    qed (simp add: subst_apply_pairs_def)
    hence "?P ?G X  ?Q ?G X"
      using 1 ineq_subterm_inj_cond_subst[OF 0, of "trmspairs F"] trmspairs_subst[of F ]
      by presburger
    moreover have "(x#S) st θ = Inequality X (F pairs )#(S st θ)"
      using x = Inequality X F by auto
    ultimately show ?thesis using IH by simp
  qed auto
qed simp

lemma tfr_stp_all_same_type:
  "list_all tfrstp (S@Equality a t t'#S')  Unifier δ t t'  Γ t = Γ t'"
by force+

lemma tfr_subset:
  "A B. tfrset (A  B)  tfrset A"
  "A B. tfrset B  A  B  tfrset A"
  "A B. tfrset B  SMP A  SMP B  tfrset A"
proof -
  show 1: "tfrset (A  B)  tfrset A" for A B
    using SMP_union[of A B] unfolding tfrset_def by simp

  fix A B assume B: "tfrset B"

  show "A  B  tfrset A"
  proof -
    assume "A  B"
    then obtain C where "B = A  C" by moura
    thus ?thesis using B 1 by blast
  qed

  show "SMP A  SMP B  tfrset A"
  proof -
    assume "SMP A  SMP B"
    then obtain C where "SMP B = SMP A  C" by moura
    thus ?thesis using B unfolding tfrset_def by blast
  qed
qed

lemma tfr_empty[simp]: "tfrset {}"
unfolding tfrset_def by simp

lemma tfr_consts_mono:
  assumes "t  M. c. t = Fun c []"
    and "t  M. Ana t = ([], [])"
    and "tfrset N"
  shows "tfrset (N  M)"
proof -
  { fix s t
    assume *: "s  SMP (N  M) - range Var" "t  SMP (N  M) - range Var" "δ. Unifier δ s t"
    hence **: "is_Fun s" "is_Fun t" "s  SMP N  s  M" "t  SMP N  t  M"
      using assms(3) SMP_consts[OF assms(1,2)] SMP_union[of N M] by auto
    moreover have "Γ s = Γ t" when "s  SMP N" "t  SMP N"
      using that assms(3) *(3) **(1,2) unfolding tfrset_def by blast
    moreover have "Γ s = Γ t" when st: "s  M" "t  M"
    proof -
      obtain c d where "s = Fun c []" "t = Fun d []" using st assms(1) by moura
      hence "s = t" using *(3) by fast
      thus ?thesis by metis
    qed
    moreover have "Γ s = Γ t" when st: "s  SMP N" "t  M"
    proof -
      obtain c where "t = Fun c []" using st assms(1) by moura
      hence "s = t" using *(3) **(1,2) by auto
      thus ?thesis by metis
    qed
    moreover have "Γ s = Γ t" when st: "s  M" "t  SMP N"
    proof -
      obtain c where "s = Fun c []" using st assms(1) by moura
      hence "s = t" using *(3) **(1,2) by auto
      thus ?thesis by metis
    qed
    ultimately have "Γ s = Γ t" by metis
  } thus ?thesis by (metis tfrset_def)
qed

lemma dualst_tfrstp: "list_all tfrstp S  list_all tfrstp (dualst S)"
proof (induction S)
  case (Cons x S)
  have "list_all tfrstp S" using Cons.prems by simp
  hence IH: "list_all tfrstp (dualst S)" using Cons.IH by metis
  from Cons show ?case
  proof (cases x)
    case (Equality a t t')
    hence "(δ. Unifier δ t t')  Γ t = Γ t'" using Cons by auto
    thus ?thesis using Equality IH by fastforce
  next
    case (Inequality X F)
    have "set (dualst (x#S)) = insert x (set (dualst S))" using Inequality by auto
    moreover have "(x  fvpairs F - set X. a. Γ (Var x) = Var a) 
            (f T. Fun f T  subtermsset (trmspairs F)  T = []  (s  set T. s  Var ` set X))" 
      using Cons.prems Inequality by auto
    ultimately show ?thesis using Inequality IH by auto
  qed auto
qed simp

lemma subst_var_inv_wt:
  assumes "wtsubst δ"
  shows "wtsubst (subst_var_inv δ X)"
using assms f_inv_into_f[of _ δ X]
unfolding wtsubst_def subst_var_inv_def
by presburger

lemma subst_var_inv_wf_trms:
  "wftrms (subst_range (subst_var_inv δ X))"
using f_inv_into_f[of _ δ X]
unfolding wtsubst_def subst_var_inv_def
by auto

lemma unify_list_wt_if_same_type:
  assumes "Unification.unify E B = Some U" "(s,t)  set E. wftrm s  wftrm t  Γ s = Γ t"
  and "(v,t)  set B. Γ (Var v) = Γ t"
  shows "(v,t)  set U. Γ (Var v) = Γ t"
using assms
proof (induction E B arbitrary: U rule: Unification.unify.induct)
  case (2 f X g Y E B U)
  hence "wftrm (Fun f X)" "wftrm (Fun g Y)" "Γ (Fun f X) = Γ (Fun g Y)" by auto

  from "2.prems"(1) obtain E' where *: "decompose (Fun f X) (Fun g Y) = Some E'"
    and [simp]: "f = g" "length X = length Y" "E' = zip X Y"
    and **: "Unification.unify (E'@E) B = Some U"
    by (auto split: option.splits)
  
  have "(s,t)  set E'. wftrm s  wftrm t  Γ s = Γ t"
  proof -
    { fix s t assume "(s,t)  set E'"
      then obtain X' X'' Y' Y'' where "X = X'@s#X''" "Y = Y'@t#Y''" "length X' = length Y'"
        using zip_arg_subterm_split[of s t X Y] E' = zip X Y by metis
      hence "Γ (Fun f (X'@s#X'')) = Γ (Fun g (Y'@t#Y''))" by (metis Γ (Fun f X) = Γ (Fun g Y))
      
      from E' = zip X Y have "(s,t)  set E'. s  Fun f X  t  Fun g Y"
        using zip_arg_subterm[of _ _ X Y] by blast
      with (s,t)  set E' have "wftrm s" "wftrm t"
        using wf_trm_subterm ‹wftrm (Fun f X) ‹wftrm (Fun g Y) by (blast,blast)
      moreover have "f  Σf"
      proof (rule ccontr)
        assume "f  Σf"
        hence "f  𝒞" "arity f = 0" using const_arity_eq_zero[of f] by simp_all
        thus False using ‹wftrm (Fun f X) * (s,t)  set E' unfolding wftrm_def by auto
      qed
      hence "Γ s = Γ t"
        using fun_type_arg_cong' f  Σf Γ (Fun f (X'@s#X'')) = Γ (Fun g (Y'@t#Y''))
              ‹length X' = length Y' f = g
        by metis
      ultimately have "wftrm s" "wftrm t" "Γ s = Γ t" by metis+
    }
    thus ?thesis by blast
  qed
  moreover have "(s,t)  set E. wftrm s  wftrm t  Γ s = Γ t" using "2.prems"(2) by auto
  ultimately show ?case using "2.IH"[OF * ** _ "2.prems"(3)] by fastforce
next
  case (3 v t E B U)
  hence "Γ (Var v) = Γ t" "wftrm t" by auto
  hence "wtsubst (subst v t)"
      and *: "(v, t)  set ((v,t)#B). Γ (Var v) = Γ t"
             "t t'. (t,t')  set E  Γ t = Γ t'"
    using "3.prems"(2,3) unfolding wtsubst_def subst_def by auto

  show ?case
  proof (cases "t = Var v")
    assume "t = Var v" thus ?case using 3 by auto
  next
    assume "t  Var v"
    hence "v  fv t" using "3.prems"(1) by auto
    hence **: "Unification.unify (subst_list (subst v t) E) ((v, t)#B) = Some U"
      using Unification.unify.simps(3)[of v t E B] "3.prems"(1) t  Var v by auto
    
    have "(s, t)  set (subst_list (subst v t) E). wftrm s  wftrm t"
      using wf_trm_subst_singleton[OF _ ‹wftrm t] "3.prems"(2)
      unfolding subst_list_def subst_def by auto
    moreover have "(s, t)  set (subst_list (subst v t) E). Γ s = Γ t"
      using *(2)[THEN wt_subst_trm'[OF ‹wtsubst (subst v t)]] by (simp add: subst_list_def)
    ultimately show ?thesis using "3.IH"(2)[OF t  Var v v  fv t ** _ *(1)] by auto
  qed
next
  case (4 f X v E B U)
  hence "Γ (Var v) = Γ (Fun f X)" "wftrm (Fun f X)" by auto
  hence "wtsubst (subst v (Fun f X))"
      and *: "(v, t)  set ((v,(Fun f X))#B). Γ (Var v) = Γ t"
             "t t'. (t,t')  set E  Γ t = Γ t'"
    using "4.prems"(2,3) unfolding wtsubst_def subst_def by auto

  have "v  fv (Fun f X)" using "4.prems"(1) by force
  hence **: "Unification.unify (subst_list (subst v (Fun f X)) E) ((v, (Fun f X))#B) = Some U"
    using Unification.unify.simps(3)[of v "Fun f X" E B] "4.prems"(1) by auto
  
  have "(s, t)  set (subst_list (subst v (Fun f X)) E). wftrm s  wftrm t"
    using wf_trm_subst_singleton[OF _ ‹wftrm (Fun f X)] "4.prems"(2)
    unfolding subst_list_def subst_def by auto
  moreover have "(s, t)  set (subst_list (subst v (Fun f X)) E). Γ s = Γ t"
    using *(2)[THEN wt_subst_trm'[OF ‹wtsubst (subst v (Fun f X))]] by (simp add: subst_list_def)
  ultimately show ?case using "4.IH"[OF v  fv (Fun f X) ** _ *(1)] by auto
qed auto

lemma mgu_wt_if_same_type:
  assumes "mgu s t = Some σ" "wftrm s" "wftrm t" "Γ s = Γ t"
  shows "wtsubst σ"
proof -
  let ?fv_disj = "λv t S. ¬((v',t')  S - {(v,t)}. (insert v (fv t))  (insert v' (fv t'))  {})"

  from assms(1) obtain σ' where "Unification.unify [(s,t)] [] = Some σ'" "subst_of σ' = σ"
    by (auto split: option.splits)
  hence "(v,t)  set σ'. Γ (Var v) = Γ t" "distinct (map fst σ')"
    using assms(2,3,4) unify_list_wt_if_same_type unify_list_distinct[of "[(s,t)]"] by auto
  thus "wtsubst σ" using ‹subst_of σ' = σ unfolding wtsubst_def
  proof (induction σ' arbitrary: σ rule: List.rev_induct)
    case (snoc tt σ' σ)
    then obtain v t where tt: "tt = (v,t)" by (metis surj_pair)
    hence σ: "σ = subst v t s subst_of σ'" using snoc.prems(3) by simp
    
    have "(v,t)  set σ'. Γ (Var v) = Γ t" "distinct (map fst σ')" using snoc.prems(1,2) by auto
    then obtain σ'' where σ'': "subst_of σ' = σ''" "v. Γ (Var v) = Γ (σ'' v)" by (metis snoc.IH)
    hence "Γ t = Γ (t  σ'')" for t using wt_subst_trm by blast
    hence "Γ (Var v) = Γ (σ'' v)" "Γ t = Γ (t  σ'')" using σ''(2) by auto
    moreover have "Γ (Var v) = Γ t" using snoc.prems(1) tt by simp
    moreover have σ2: "σ = Var(v := t) s σ'' " using σ σ''(1) unfolding subst_def by simp
    ultimately have "Γ (Var v) = Γ (σ v)" unfolding subst_compose_def by simp

    have "subst_domain (subst v t)  {v}" unfolding subst_def by (auto simp add: subst_domain_def)
    hence *: "subst_domain σ  insert v (subst_domain σ'')"
      using tt σ σ''(1) snoc.prems(2) subst_domain_compose[of _ σ'']
      by (auto simp add: subst_domain_def)
    
    have "v  set (map fst σ')" using tt snoc.prems(2) by auto
    hence "v  subst_domain σ''" using σ''(1) subst_of_dom_subset[of σ'] by auto

    { fix w assume "w  subst_domain σ''"
      hence "σ w = σ'' w" using σ2 σ''(1) v  subst_domain σ'' unfolding subst_compose_def by auto
      hence "Γ (Var w) = Γ (σ w)" using σ''(2) by simp
    }
    thus ?case using Γ (Var v) = Γ (σ v) * by force
  qed simp
qed

lemma wt_Unifier_if_Unifier:
  assumes s_t: "wftrm s" "wftrm t" "Γ s = Γ t"
    and δ: "Unifier δ s t"
  shows "θ. Unifier θ s t  wtsubst θ  wftrms (subst_range θ)"
using mgu_always_unifies[OF δ] mgu_gives_MGU[THEN MGU_is_Unifier[of s _ t]]
      mgu_wt_if_same_type[OF _ s_t] mgu_wf_trm[OF _ s_t(1,2)] wf_trm_subst_range_iff
by fast

end


subsection ‹Automatically Proving Type-Flaw Resistance›
subsubsection ‹Definitions: Variable Renaming›
abbreviation "max_var t  Max (insert 0 (snd ` fv t))"
abbreviation "max_var_set X  Max (insert 0 (snd ` X))"

definition "var_rename n v  Var (fst v, snd v + Suc n)"
definition "var_rename_inv n v  Var (fst v, snd v - Suc n)"


subsubsection ‹Definitions: Computing a Finite Representation of the Sub-Message Patterns›
text ‹A sufficient requirement for a term to be a well-typed instance of another term›
definition is_wt_instance_of_cond where
  "is_wt_instance_of_cond Γ t s  (
    Γ t = Γ s  (case mgu t s of
      None  False
    | Some δ  inj_on δ (fv t)  (x  fv t. is_Var (δ x))))"

definition has_all_wt_instances_of where
  "has_all_wt_instances_of Γ N M  t  N. s  M. is_wt_instance_of_cond Γ t s"

text ‹This function computes a finite representation of the set of sub-message patterns›
definition SMP0 where
  "SMP0 Ana Γ M  let
      f = λt. Fun (the_Fun (Γ t)) (map Var (zip (args (Γ t)) [0..<length (args (Γ t))]));
      g = λM'. map f (filter (λt. is_Var t  is_Fun (Γ t)) M')@
               concat (map (fst  Ana) M')@concat (map subterms_list M');
      h = remdups  g
    in while (λA. set (h A)  set A) h M"

text ‹These definitions are useful to refine an SMP representation set›
fun generalize_term where
  "generalize_term _ _ n (Var x) = (Var x, n)"
| "generalize_term Γ p n (Fun f T) = (let τ = Γ (Fun f T)
    in if p τ then (Var (τ, n), Suc n)
       else let (T',n') = foldr (λt (S,m). let (t',m') = generalize_term Γ p m t in (t'#S,m'))
                                T ([],n)
            in (Fun f T', n'))"

definition generalize_terms where
  "generalize_terms Γ p  map (fst  generalize_term Γ p 0)"

definition remove_superfluous_terms where
  "remove_superfluous_terms Γ T 
    let
      f = λS t R. s  set S - R. s  t  is_wt_instance_of_cond Γ t s;
      g = λS t (U,R). if f S t R then (U, insert t R) else (t#U, R);
      h = λS. remdups (fst (foldr (g S) S ([],{})))
    in while (λS. h S  S) h T"


subsubsection ‹Definitions: Checking Type-Flaw Resistance›
definition is_TComp_var_instance_closed where
  "is_TComp_var_instance_closed Γ M  x  fvset (set M). is_Fun (Γ (Var x)) 
      list_ex (λt. is_Fun t  Γ t = Γ (Var x)  list_all is_Var (args t)  distinct (args t)) M"

definition finite_SMP_representation where
  "finite_SMP_representation arity Ana Γ M 
    list_all (wftrm' arity) M 
    has_all_wt_instances_of Γ (subtermsset (set M)) (set M) 
    has_all_wt_instances_of Γ (((set  fst  Ana) ` set M)) (set M) 
    is_TComp_var_instance_closed Γ M"

definition comp_tfrset where
  "comp_tfrset arity Ana Γ M 
    finite_SMP_representation arity Ana Γ M 
    (let δ = var_rename (max_var_set (fvset (set M)))
     in s  set M. t  set M. is_Fun s  is_Fun t  Γ s  Γ t  mgu s (t  δ) = None)"

fun comp_tfrstp where
  "comp_tfrstp Γ (_: t  t'st) = (mgu t t'  None  Γ t = Γ t')"
| "comp_tfrstp Γ (X⟨∨≠: Fst) = (
    (x  fvpairs F - set X. is_Var (Γ (Var x))) 
    (u  subtermsset (trmspairs F).
      is_Fun u  (args u = []  (s  set (args u). s  Var ` set X))))"
| "comp_tfrstp _ _ = True"

definition comp_tfrst where
  "comp_tfrst arity Ana Γ M S 
    list_all (comp_tfrstp Γ) S 
    list_all (wftrm' arity) (trms_listst S) 
    has_all_wt_instances_of Γ (trmsst S) (set M) 
    comp_tfrset arity Ana Γ M"


subsubsection ‹Small Lemmata›
lemma less_Suc_max_var_set:
  assumes z: "z  X"
    and X: "finite X"
  shows "snd z < Suc (max_var_set X)"
proof -
  have "snd z  snd ` X" using z by simp
  hence "snd z  Max (insert 0 (snd ` X))" using X by simp
  thus ?thesis using X by simp
qed

lemma (in typed_model) finite_SMP_representationD:
  assumes "finite_SMP_representation arity Ana Γ M"
  shows "wftrms (set M)"
    and "has_all_wt_instances_of Γ (subtermsset (set M)) (set M)"
    and "has_all_wt_instances_of Γ (((set  fst  Ana) ` set M)) (set M)"
    and "is_TComp_var_instance_closed Γ M"
using assms unfolding finite_SMP_representation_def list_all_iff wftrm_code by blast+

lemma (in typed_model) is_wt_instance_of_condD:
  assumes t_instance_s: "is_wt_instance_of_cond Γ t s"
  obtains δ where
    "Γ t = Γ s" "mgu t s = Some δ"
    "inj_on δ (fv t)" "δ ` (fv t)  range Var"
using t_instance_s unfolding is_wt_instance_of_cond_def Let_def by (cases "mgu t s") fastforce+

lemma (in typed_model) is_wt_instance_of_condD':
  assumes t_wf_trm: "wftrm t"
    and s_wf_trm: "wftrm s"
    and t_instance_s: "is_wt_instance_of_cond Γ t s"
  shows "δ. wtsubst δ  wftrms (subst_range δ)  t = s  δ"
proof -
  obtain δ where s:
      "Γ t = Γ s" "mgu t s = Some δ"
      "inj_on δ (fv t)" "δ ` (fv t)  range Var"
    by (metis is_wt_instance_of_condD[OF t_instance_s])

  have 0: "wftrm t" "wftrm s" using s(1) t_wf_trm s_wf_trm by auto

  note 1 = mgu_wt_if_same_type[OF s(2) 0 s(1)]

  note 2 = conjunct1[OF mgu_gives_MGU[OF s(2)]]

  show ?thesis
    using s(1) inj_var_ran_unifiable_has_subst_match[OF 2 s(3,4)]
          wt_subst_compose[OF 1 subst_var_inv_wt[OF 1, of "fv t"]]
          wf_trms_subst_compose[OF mgu_wf_trms[OF s(2) 0] subst_var_inv_wf_trms[of δ "fv t"]]
    by auto
qed

lemma (in typed_model) is_wt_instance_of_condD'':
  assumes s_wf_trm: "wftrm s"
    and t_instance_s: "is_wt_instance_of_cond Γ t s"
    and t_var: "t = Var x"
  shows "y. s = Var y  Γ (Var y) = Γ (Var x)"
proof -
  obtain δ where δ: "wtsubst δ" and s: "Var x = s  δ"
    using is_wt_instance_of_condD'[OF _ s_wf_trm t_instance_s] t_var by auto
  obtain y where y: "s = Var y" using s by (cases s) auto
  show ?thesis using wt_subst_trm''[OF δ] s y by metis
qed

lemma (in typed_model) has_all_wt_instances_ofD:
  assumes N_instance_M: "has_all_wt_instances_of Γ N M"
    and t_in_N: "t  N"
  obtains s δ where
    "s  M" "Γ t = Γ s" "mgu t s = Some δ"
    "inj_on δ (fv t)" "δ ` (fv t)  range Var"
by (metis t_in_N N_instance_M is_wt_instance_of_condD has_all_wt_instances_of_def)

lemma (in typed_model) has_all_wt_instances_ofD':
  assumes N_wf_trms: "wftrms N"
    and M_wf_trms: "wftrms M"
    and N_instance_M: "has_all_wt_instances_of Γ N M"
    and t_in_N: "t  N"
  shows "δ. wtsubst δ  wftrms (subst_range δ)  t  M set δ"
using assms is_wt_instance_of_condD' unfolding has_all_wt_instances_of_def by fast

lemma (in typed_model) has_all_wt_instances_ofD'':
  assumes N_wf_trms: "wftrms N"
    and M_wf_trms: "wftrms M"
    and N_instance_M: "has_all_wt_instances_of Γ N M"
    and t_in_N: "Var x  N"
  shows "y. Var y  M  Γ (Var y) = Γ (Var x)"
using assms is_wt_instance_of_condD'' unfolding has_all_wt_instances_of_def by fast
  
lemma (in typed_model) has_all_instances_of_if_subset:
  assumes "N  M"
  shows "has_all_wt_instances_of Γ N M"
using assms inj_onI mgu_same_empty
unfolding has_all_wt_instances_of_def is_wt_instance_of_cond_def
by (smt option.case_eq_if option.discI option.sel subsetD term.discI(1) term.inject(1))

lemma (in typed_model) SMP_I':
  assumes N_wf_trms: "wftrms N"
    and M_wf_trms: "wftrms M"
    and N_instance_M: "has_all_wt_instances_of Γ N M"
    and t_in_N: "t  N"
  shows "t  SMP M"
using has_all_wt_instances_ofD'[OF N_wf_trms M_wf_trms N_instance_M t_in_N]
      SMP.Substitution[OF SMP.MP[of _ M]]
by blast


subsubsection ‹Lemma: Proving Type-Flaw Resistance›
locale typed_model' = typed_model arity public Ana Γ
  for arity::"'fun  nat"
    and public::"'fun  bool"
    and Ana::"('fun,(('fun,'atom::finite) term_type × nat)) term
               (('fun,(('fun,'atom) term_type × nat)) term list
                 × ('fun,(('fun,'atom) term_type × nat)) term list)"
    and Γ::"('fun,(('fun,'atom) term_type × nat)) term  ('fun,'atom) term_type"
  +
  assumes Γ_Var_fst: "τ n m. Γ (Var (τ,n)) = Γ (Var (τ,m))"
    and Ana_const: "c T. arity c = 0  Ana (Fun c T) = ([],[])"
    and Ana_subst'_or_Ana_keys_subterm:
      "(f T δ K R. Ana (Fun f T) = (K,R)  Ana (Fun f T  δ) = (K list δ,R list δ)) 
       (t K R k. Ana t = (K,R)  k  set K  k  t)"
begin

lemma var_rename_inv_comp: "t  (var_rename n s var_rename_inv n) = t"
proof (induction t)
  case (Fun f T)
  hence "map (λt. t  var_rename n s var_rename_inv n) T = T" by (simp add: map_idI) 
  thus ?case by (metis subst_apply_term.simps(2)) 
qed (simp add: var_rename_def var_rename_inv_def)

lemma var_rename_fv_disjoint:
  "fv s  fv (t  var_rename (max_var s)) = {}"
proof -
  have 1: "v  fv s. snd v  max_var s" by simp
  have 2: "v  fv (t  var_rename n). snd v > n" for n unfolding var_rename_def by (induct t) auto
  show ?thesis using 1 2 by force
qed

lemma var_rename_fv_set_disjoint:
  assumes "finite M" "s  M"
  shows "fv s  fv (t  var_rename (max_var_set (fvset M))) = {}"
proof -
  have 1: "v  fv s. snd v  max_var_set (fvset M)" using assms
  proof (induction M rule: finite_induct)
    case (insert t M) thus ?case
    proof (cases "t = s")
      case False
      hence "v  fv s. snd v  max_var_set (fvset M)" using insert by simp
      moreover have "max_var_set (fvset M)  max_var_set (fvset (insert t M))"
        using insert.hyps(1) insert.prems
        by force
      ultimately show ?thesis by auto
    qed simp
  qed simp

  have 2: "v  fv (t  var_rename n). snd v > n" for n unfolding var_rename_def by (induct t) auto

  show ?thesis using 1 2 by force
qed

lemma var_rename_fv_set_disjoint':
  assumes "finite M"
  shows "fvset M  fvset (N set var_rename (max_var_set (fvset M))) = {}"
using var_rename_fv_set_disjoint[OF assms] by auto

lemma var_rename_is_renaming[simp]:
  "subst_range (var_rename n)  range Var"
  "subst_range (var_rename_inv n)  range Var"
unfolding var_rename_def var_rename_inv_def by auto

lemma var_rename_wt[simp]:
  "wtsubst (var_rename n)"
  "wtsubst (var_rename_inv n)"
by (auto simp add: var_rename_def var_rename_inv_def wtsubst_def Γ_Var_fst)

lemma var_rename_wt':
  assumes "wtsubst δ" "s = m  δ"
  shows "wtsubst (var_rename_inv n s δ)" "s = m  var_rename n  var_rename_inv n s δ"
using assms(2) wt_subst_compose[OF var_rename_wt(2)[of n] assms(1)] var_rename_inv_comp[of m n]
by force+

lemma var_rename_wftrms_range[simp]:
  "wftrms (subst_range (var_rename n))"
  "wftrms (subst_range (var_rename_inv n))"
using var_rename_is_renaming by fastforce+

lemma Fun_range_case:
  "(f T. Fun f T  M  P f T)  (u  M. case u of Fun f T  P f T | _  True)"
  "(f T. Fun f T  M  P f T)  (u  M. is_Fun u  P (the_Fun u) (args u))"
by (auto split: "term.splits")

lemma is_TComp_var_instance_closedD:
  assumes x: "y  fvset (set M). Γ (Var x) = Γ (Var y)" "Γ (Var x) = TComp f T"
    and closed: "is_TComp_var_instance_closed Γ M"
  shows "g U. Fun g U  set M  Γ (Fun g U) = Γ (Var x)  (u  set U. is_Var u)  distinct U"
using assms unfolding is_TComp_var_instance_closed_def list_all_iff list_ex_iff by fastforce

lemma is_TComp_var_instance_closedD':
  assumes "y  fvset (set M). Γ (Var x) = Γ (Var y)" "TComp f T  Γ (Var x)"
    and closed: "is_TComp_var_instance_closed Γ M"
    and wf: "wftrms (set M)"
  shows "g U. Fun g U  set M  Γ (Fun g U) = TComp f T  (u  set U. is_Var u)  distinct U"
using assms(1,2)
proof (induction "Γ (Var x)" arbitrary: x)
  case (Fun g U)
  note IH = Fun.hyps(1)
  have g: "arity g > 0" "public g" using Fun.hyps(2) fun_type_inv[of "Var x"] Γ_Var_fst by simp_all
  then obtain V where V:
      "Fun g V  set M" "Γ (Fun g V) = Γ (Var x)" "v  set V. x. v = Var x"
      "distinct V" "length U = length V"
    using is_TComp_var_instance_closedD[OF Fun.prems(1) Fun.hyps(2)[symmetric] closed(1)]
    by (metis Fun.hyps(2) fun_type_id_eq fun_type_length_eq is_VarE)
  hence U: "U = map Γ V" using fun_type[OF g(1), of V] Fun.hyps(2) by simp
  hence 1: "Γ v  set U" when v: "v  set V" for v using v by simp

  have 2: "y  fvset (set M). Γ (Var z) = Γ (Var y)" when z: "Var z  set V" for z
    using V(1) fv_subset_subterms Fun_param_in_subterms[OF z] by fastforce

  show ?case
  proof (cases "TComp f T = Γ (Var x)")
    case False
    then obtain u where u: "u  set U" "TComp f T  u"
      using Fun.prems(2) Fun.hyps(2) by moura
    then obtain y where y: "Var y  set V" "Γ (Var y) = u" using U V(3) Γ_Var_fst by auto
    show ?thesis using IH[OF _ 2[OF y(1)]] u y(2) by metis
  qed (use V in fastforce)
qed simp

lemma TComp_var_instance_wt_subst_exists:
  assumes gT: "Γ (Fun g T) = TComp g (map Γ U)" "wftrm (Fun g T)"
    and U: "u  set U. y. u = Var y" "distinct U"
  shows "θ. wtsubst θ  wftrms (subst_range θ)  Fun g T = Fun g U  θ"
proof -
  define the_i where "the_i  λy. THE x. x < length U  U ! x = Var y"
  define θ where θ: "θ  λy. if Var y  set U then T ! the_i y else Var y"

  have g: "arity g > 0" using gT(1,2) fun_type_inv(1) by blast

  have UT: "length U = length T" using fun_type_length_eq gT(1) by fastforce

  have 1: "the_i y < length U  U ! the_i y = Var y" when y: "Var y  set U" for y
    using theI'[OF distinct_Ex1[OF U(2) y]] unfolding the_i_def by simp

  have 2: "wtsubst θ"
    using θ 1 gT(1) fun_type[OF g] UT
    unfolding wtsubst_def
    by (metis (no_types, lifting) nth_map term.inject(2))

  have "i<length T. U ! i  θ = T ! i"
    using θ 1 U(1) UT distinct_Ex1[OF U(2)] in_set_conv_nth
    by (metis (no_types, lifting) subst_apply_term.simps(1))
  hence "T = map (λt. t  θ) U" by (simp add: UT nth_equalityI)
  hence 3: "Fun g T = Fun g U  θ" by simp

  have "subst_range θ  set T" using θ 1 U(1) UT by (auto simp add: subst_domain_def)
  hence 4: "wftrms (subst_range θ)" using gT(2) wf_trm_param by auto

  show ?thesis by (metis 2 3 4)
qed

lemma TComp_var_instance_closed_has_Var:
  assumes closed: "is_TComp_var_instance_closed Γ M"
    and wf_M: "wftrms (set M)"
    and wf_δx: "wftrm (δ x)"
    and y_ex: "y  fvset (set M). Γ (Var x) = Γ (Var y)"
    and t: "t  δ x"
    and δ_wt: "wtsubst δ"
  shows "y  fvset (set M). Γ (Var y) = Γ t"
proof (cases "Γ (Var x)")
  case (Var a)
  hence "t = δ x"
    using t wf_δx δ_wt
    by (metis (full_types) const_type_inv_wf fun_if_subterm subtermeq_Var_const(2) wtsubst_def)
  thus ?thesis using y_ex wt_subst_trm''[OF δ_wt, of "Var x"] by fastforce
next
  case (Fun f T)
  hence Γ_δx: "Γ (δ x) = TComp f T" using wt_subst_trm''[OF δ_wt, of "Var x"] by auto

  show ?thesis
  proof (cases "t = δ x")
    case False
    hence t_subt_δx: "t  δ x" using t(1) Γ_δx by fastforce

    obtain T' where T': "δ x = Fun f T'" using Γ_δx t_subt_δx fun_type_id_eq by (cases "δ x") auto
    
    obtain g S where gS: "Fun g S  δ x" "t  set S" using Fun_ex_if_subterm[OF t_subt_δx] by blast
  
    have gS_wf: "wftrm (Fun g S)" by (rule wf_trm_subtermeq[OF wf_δx gS(1)])
    hence "arity g > 0" using gS(2) by (metis length_pos_if_in_set wf_trm_arity) 
    hence gS_Γ: "Γ (Fun g S) = TComp g (map Γ S)" using fun_type by blast
  
    obtain h U where hU:
        "Fun h U  set M" "Γ (Fun h U) = Fun g (map Γ S)" "u  set U. is_Var u"
      using is_TComp_var_instance_closedD'[OF y_ex _ closed wf_M]
            subtermeq_imp_subtermtypeeq[OF wf_δx] gS Γ_δx Fun gS_Γ
      by metis
  
    obtain y where y: "Var y  set U" "Γ (Var y) = Γ t"
      using hU(3) fun_type_param_ex[OF hU(2) gS(2)] by fast
  
    have "y  fvset (set M)" using hU(1) y(1) by force
    thus ?thesis using y(2) closed by metis
  qed (metis y_ex Fun Γ_δx)
qed

lemma TComp_var_instance_closed_has_Fun:
  assumes closed: "is_TComp_var_instance_closed Γ M"
    and wf_M: "wftrms (set M)"
    and wf_δx: "wftrm (δ x)"
    and y_ex: "y  fvset (set M). Γ (Var x) = Γ (Var y)"
    and t: "t  δ x"
    and δ_wt: "wtsubst δ"
    and t_Γ: "Γ t = TComp g T"
    and t_fun: "is_Fun t"
  shows "m  set M. θ. wtsubst θ  wftrms (subst_range θ)  t = m  θ  is_Fun m"
proof -
  obtain T'' where T'': "t = Fun g T''" using t_Γ t_fun fun_type_id_eq by blast

  have g: "arity g > 0" using t_Γ fun_type_inv[of t] by simp_all

  have "TComp g T  Γ (Var x)" using δ_wt t t_Γ
    by (metis wf_δx subtermeq_imp_subtermtypeeq wtsubst_def) 
  then obtain U where U:
      "Fun g U  set M" "Γ (Fun g U) = TComp g T" "u  set U. y. u = Var y"
      "distinct U" "length T'' = length U"
    using is_TComp_var_instance_closedD'[OF y_ex _ closed wf_M]
    by (metis t_Γ T'' fun_type_id_eq fun_type_length_eq is_VarE)
  hence UT': "T = map Γ U" using fun_type[OF g, of U] by simp

  show ?thesis
    using TComp_var_instance_wt_subst_exists UT' T'' U(1,3,4) t t_Γ wf_δx wf_trm_subtermeq
    by (metis term.disc(2))
qed

lemma TComp_var_and_subterm_instance_closed_has_subterms_instances:
  assumes M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
    and M_subterms_cl: "has_all_wt_instances_of Γ (subtermsset (set M)) (set M)"
    and M_wf: "wftrms (set M)"
    and t: "t set set M"
    and s: "s  t  δ"
    and δ: "wtsubst δ" "wftrms (subst_range δ)"
  shows "m  set M. θ. wtsubst θ  wftrms (subst_range θ)  s = m  θ"
using subterm_subst_unfold[OF s]
proof
  assume "s'. s'  t  s = s'  δ"
  then obtain s' where s': "s'  t" "s = s'  δ" by blast
  then obtain θ where θ: "wtsubst θ" "wftrms (subst_range θ)" "s'  set M set θ"
    using t has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl]
          term.order_trans[of s' t]
    by blast
  then obtain m where m: "m  set M" "s' = m  θ" by blast

  have "s = m  (θ s δ)" using s'(2) m(2) by simp
  thus ?thesis
    using m(1) wt_subst_compose[OF θ(1) δ(1)] wf_trms_subst_compose[OF θ(2) δ(2)] by blast
next
  assume "x  fv t. s  δ x"
  then obtain x where x: "x  fv t" "s  δ x" "s  δ x" by blast

  note 0 = TComp_var_instance_closed_has_Var[OF M_var_inst_cl M_wf]
  note 1 = has_all_wt_instances_ofD''[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl]

  have δx_wf: "wftrm (δ x)" and s_wf_trm: "wftrm s"
    using δ(2) wf_trm_subterm[OF _ x(2)] by fastforce+

  have x_fv_ex: "y  fvset (set M). Γ (Var x) = Γ (Var y)"
    using x(1) s fv_subset_subterms[OF t] by auto

  obtain y where y: "y  fvset (set M)" "Γ (Var y) = Γ s"
    using 0[of δ x s, OF δx_wf x_fv_ex x(3) δ(1)] by metis
  then obtain z where z: "Var z  set M" "Γ (Var z) = Γ s"
    using 1[of y] vars_iff_subtermeq_set[of y "set M"] by metis

  define θ where "θ  Var(z := s)::('fun, ('fun, 'atom) term × nat) subst"

  have "wtsubst θ" "wftrms (subst_range θ)" "s = Var z  θ"
    using z(2) s_wf_trm unfolding θ_def wtsubst_def by force+
  thus ?thesis using z(1) by blast
qed

context
begin
private lemma SMP_D_aux1:
  assumes "t  SMP (set M)"
    and closed: "has_all_wt_instances_of Γ (subtermsset (set M)) (set M)"
                "is_TComp_var_instance_closed Γ M"
    and wf_M: "wftrms (set M)"
  shows "x  fv t. y  fvset (set M). Γ (Var y) = Γ (Var x)"
using assms(1)
proof (induction t rule: SMP.induct)
  case (MP t) show ?case
  proof
    fix x assume x: "x  fv t"
    hence "Var x  subtermsset (set M)" using MP.hyps vars_iff_subtermeq by fastforce
    then obtain δ s where δ: "wtsubst δ" "wftrms (subst_range δ)"
        and s: "s  set M" "Var x = s  δ"
      using has_all_wt_instances_ofD'[OF wf_trms_subterms[OF wf_M] wf_M closed(1)] by blast
    then obtain y where y: "s = Var y" by (cases s) auto
    thus "y  fvset (set M). Γ (Var y) = Γ (Var x)"
      using s wt_subst_trm''[OF δ(1), of "Var y"] by force
  qed
next
  case (Subterm t t')
  hence "fv t'  fv t" using subtermeq_vars_subset by auto
  thus ?case using Subterm.IH by auto
next
  case (Substitution t δ)
  note IH = Substitution.IH
  show ?case
  proof
    fix x assume x: "x  fv (t  δ)"
    then obtain y where y: "y  fv t" "Γ (Var x)  Γ (Var y)"
      using Substitution.hyps(2,3)
      by (metis subst_apply_img_var subtermeqI' subtermeq_imp_subtermtypeeq
                vars_iff_subtermeq wtsubst_def wf_trm_subst_rangeD)
    let ?P = "λx. y  fvset (set M). Γ (Var y) = Γ (Var x)"
    show "?P x" using y IH
    proof (induction "Γ (Var y)" arbitrary: y t)
      case (Var a)
      hence "Γ (Var x) = Γ (Var y)" by auto
      thus ?case using Var(2,4) by auto
    next
      case (Fun f T)
      obtain z where z: "w  fvset (set M). Γ (Var z) = Γ (Var w)" "Γ (Var z) = Γ (Var y)"
        using Fun.prems(1,3) by blast
      show ?case
      proof (cases "Γ (Var x) = Γ (Var y)")
        case True thus ?thesis using Fun.prems by auto
      next
        case False
        then obtain τ where τ: "τ  set T" "Γ (Var x)  τ" using Fun.prems(2) Fun.hyps(2) by auto
        then obtain U where U:
            "Fun f U  set M" "Γ (Fun f U) = Γ (Var z)" "u  set U. v. u = Var v" "distinct U"
          using is_TComp_var_instance_closedD'[OF z(1) _ closed(2) wf_M] Fun.hyps(2) z(2)
          by (metis fun_type_id_eq subtermeqI' is_VarE)
        hence 1: "x  fv (Fun f U). y  fvset (set M). Γ (Var y) = Γ (Var x)" by force

        have "arity f > 0" using U(2) z(2) Fun.hyps(2) fun_type_inv(1) by metis
        hence "Γ (Fun f U) = TComp f (map Γ U)" using fun_type by auto
        then obtain u where u: "Var u  set U" "Γ (Var u) = τ"
          using τ(1) U(2,3) z(2) Fun.hyps(2) by auto
        show ?thesis
          using Fun.hyps(1)[of u "Fun f U"] u τ 1
          by force
      qed
    qed
  qed
next
  case (Ana t K T k)
  have "fv k  fv t" using Ana_keys_fv[OF Ana.hyps(2)] Ana.hyps(3) by auto
  thus ?case using Ana.IH by auto
qed

private lemma SMP_D_aux2:
  fixes t::"('fun, ('fun, 'atom) term × nat) term"
  assumes t_SMP: "t  SMP (set M)"
    and t_Var: "x. t = Var x"
    and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
  shows "m  set M. δ. wtsubst δ  wftrms (subst_range δ)  t = m  δ"
proof -
  have M_wf: "wftrms (set M)" 
      and M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
      and M_subterms_cl: "has_all_wt_instances_of Γ (subtermsset (set M)) (set M)"
      and M_Ana_cl: "has_all_wt_instances_of Γ (((set  fst  Ana) ` set M)) (set M)"
    using finite_SMP_representationD[OF M_SMP_repr] by blast+

  have M_Ana_wf: "wftrms ( ((set  fst  Ana) ` set M))"
  proof
    fix k assume "k  ((set  fst  Ana) ` set M)"
    then obtain m where m: "m  set M" "k  set (fst (Ana m))" by force
    thus "wftrm k" using M_wf Ana_keys_wf'[of m "fst (Ana m)" _ k] surjective_pairing by blast
  qed

  note 0 = has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl]
  note 1 = has_all_wt_instances_ofD'[OF M_Ana_wf M_wf M_Ana_cl]

  obtain x y where x: "t = Var x" and y: "y  fvset (set M)" "Γ (Var y) = Γ (Var x)"
    using t_Var SMP_D_aux1[OF t_SMP M_subterms_cl M_var_inst_cl M_wf] by fastforce
  then obtain m δ where m: "m  set M" "m  δ = Var y" and δ: "wtsubst δ"
    using 0[of "Var y"] vars_iff_subtermeq_set[of y "set M"] by fastforce
  obtain z where z: "m = Var z" using m(2) by (cases m) auto

  define θ where "θ  Var(z := Var x)::('fun, ('fun, 'atom) term × nat) subst"

  have "Γ (Var z) = Γ (Var x)" using y(2) m(2) z wt_subst_trm''[OF δ, of m] by argo
  hence "wtsubst θ" "wftrms (subst_range θ)" unfolding θ_def wtsubst_def by force+
  moreover have "t = m  θ" using x z unfolding θ_def by simp
  ultimately show ?thesis using m(1) by blast
qed

private lemma SMP_D_aux3:
  assumes hyps: "t'  t" and wf_t: "wftrm t" and prems: "is_Fun t'"
    and IH:
      "((f. t = Fun f [])  (m  set M. δ. wtsubst δ  wftrms (subst_range δ)  t = m  δ)) 
       (m  set M. δ. wtsubst δ  wftrms (subst_range δ)  t = m  δ  is_Fun m)"
    and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
  shows "((f. t' = Fun f [])  (m  set M. δ. wtsubst δ  wftrms (subst_range δ)  t' = m  δ)) 
         (m  set M. δ. wtsubst δ  wftrms (subst_range δ)  t' = m  δ  is_Fun m)"
proof (cases "f. t = Fun f []  t' = Fun f []")
  case True
  have M_wf: "wftrms (set M)" 
    and M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
    and M_subterms_cl: "has_all_wt_instances_of Γ (subtermsset (set M)) (set M)"
    and M_Ana_cl: "has_all_wt_instances_of Γ (((set  fst  Ana) ` set M)) (set M)"
  using finite_SMP_representationD[OF M_SMP_repr] by blast+

  note 0 = has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl]
  note 1 = TComp_var_instance_closed_has_Fun[OF M_var_inst_cl M_wf]
  note 2 = TComp_var_and_subterm_instance_closed_has_subterms_instances[
            OF M_var_inst_cl M_subterms_cl M_wf]

  have wf_t': "wftrm t'" using hyps wf_t wf_trm_subterm by blast

  obtain c where "t = Fun c []  t' = Fun c []" using True by moura
  thus ?thesis
  proof
    assume c: "t' = Fun c []"
    show ?thesis
    proof (cases "f. t = Fun f []")
      case True
      hence "t = t'" using c hyps by force
      thus ?thesis using IH by fast
    next
      case False
      note F = this
      then obtain m δ where m: "m  set M" "t = m  δ"
          and δ: "wtsubst δ" "wftrms (subst_range δ)"
        using IH by blast

      show ?thesis using subterm_subst_unfold[OF hyps[unfolded m(2)]]
      proof
        assume "m'. m'  m  t' = m'  δ"
        then obtain m' where m': "m'  m" "t' = m'  δ" by moura
        obtain n θ where n: "n  set M" "m' = n  θ" and θ: "wtsubst θ" "wftrms (subst_range θ)"
          using 0[of m'] m(1) m'(1) by blast
        have "t' = n  (θ s δ)" using m'(2) n(2) by auto
        thus ?thesis
          using c n(1) wt_subst_compose[OF θ(1) δ(1)] wf_trms_subst_compose[OF θ(2) δ(2)] by blast
      next
        assume "x  fv m. t'  δ x"
        then obtain x where x: "x  fv m" "t'  δ x" "t'  δ x" by moura
        have δx_wf: "wftrm (δ x)" using δ(2) by fastforce
        
        have x_fv_ex: "y  fvset (set M). Γ (Var x) = Γ (Var y)" using x m by auto

        show ?thesis
        proof (cases "Γ t'")
          case (Var a)
          show ?thesis
            using c m 2[OF _ hyps[unfolded m(2)] δ]
            by fast
        next
          case (Fun g S)
          show ?thesis
            using c 1[of δ x t', OF δx_wf x_fv_ex x(3) δ(1) Fun]
            by blast
        qed
      qed
    qed
  qed (use IH hyps in simp)
next
  case False
  note F = False
  then obtain m δ where m:
      "m  set M" "wtsubst δ" "t = m  δ" "is_Fun m" "wftrms (subst_range δ)"
    using IH by moura
  obtain f T where fT: "t' = Fun f T" "arity f > 0" "Γ t' = TComp f (map Γ T)"
    using F prems fun_type wf_trm_subtermeq[OF wf_t hyps]
    by (metis is_FunE length_greater_0_conv subtermeqI' wftrm_def)

  have closed: "has_all_wt_instances_of Γ (subtermsset (set M)) (set M)"
               "is_TComp_var_instance_closed Γ M"
    using M_SMP_repr unfolding finite_SMP_representation_def by metis+

  have M_wf: "wftrms (set M)" 
    using finite_SMP_representationD[OF M_SMP_repr] by blast

  show ?thesis
  proof (cases "x  fv m. t'  δ x")
    case True
    then obtain x where x: "x  fv m" "t'  δ x" by moura
    have 1: "x  fvset (set M)" using m(1) x(1) by auto
    have 2: "is_Fun (δ x)" using prems x(2) by auto
    have 3: "wftrm (δ x)" using m(5) by (simp add: wf_trm_subst_rangeD)
    have "¬(f. δ x = Fun f [])" using F x(2) by auto
    hence "f T. Γ (Var x) = TComp f T" using 2 3 m(2)
      by (metis (no_types) fun_type is_FunE length_greater_0_conv subtermeqI' wftrm_def wtsubst_def)
    moreover have "f T. Γ t' = Fun f T"
      using False prems wf_trm_subtermeq[OF wf_t hyps]
      by (metis (no_types) fun_type is_FunE length_greater_0_conv subtermeqI' wftrm_def)
    ultimately show ?thesis
      using TComp_var_instance_closed_has_Fun 1 x(2) m(2) prems closed 3 M_wf
      by metis
  next
    case False
    then obtain m' where m': "m'  m" "t' = m'  δ" "is_Fun m'"
      using hyps m(3) subterm_subst_not_img_subterm
      by blast
    then obtain θ m'' where θ: "wtsubst θ" "wftrms (subst_range θ)" "m''  set M" "m' = m''  θ"
      using m(1) has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf closed(1)] by blast
    hence t'_m'': "t' = m''  θ s δ" using m'(2) by fastforce

    note θδ = wt_subst_compose[OF θ(1) m(2)] wf_trms_subst_compose[OF θ(2) m(5)]

    show ?thesis
    proof (cases "is_Fun m''")
      case True thus ?thesis using θ(3,4) m'(2,3) m(4) fT t'_m'' θδ by blast
    next
      case False
      then obtain x where x: "m'' = Var x" by moura
      hence "y  fvset (set M). Γ (Var x) = Γ (Var y)" "t'  (θ s δ) x"
            "Γ (Var x) = Fun f (map Γ T)" "wftrm ((θ s δ) x)"
        using θδ t'_m'' θ(3) fv_subset[OF θ(3)] fT(3) subst_apply_term.simps(1)[of x "θ s δ"]
              wt_subst_trm''[OF θδ(1), of "Var x"]
        by (fastforce, blast, argo, fastforce)
      thus ?thesis
        using x TComp_var_instance_closed_has_Fun[
                of M "θ s δ" x t' f "map Γ T", OF closed(2) M_wf _ _ _ θδ(1) fT(3) prems]
        by blast
    qed
  qed
qed

lemma SMP_D:
  assumes "t  SMP (set M)" "is_Fun t"
    and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
  shows "((f. t = Fun f [])  (m  set M. δ. wtsubst δ  wftrms (subst_range δ)  t = m  δ)) 
         (m  set M. δ. wtsubst δ  wftrms (subst_range δ)  t = m  δ  is_Fun m)"
proof -
  have wf_M: "wftrms (set M)"
      and closed: "has_all_wt_instances_of Γ (subtermsset (set M)) (set M)"
                  "has_all_wt_instances_of Γ (((set  fst  Ana) ` set M)) (set M)"
                  "is_TComp_var_instance_closed Γ M"
    using finite_SMP_representationD[OF M_SMP_repr] by blast+

  show ?thesis using assms(1,2)
  proof (induction t rule: SMP.induct)
    case (MP t)
    moreover have "wtsubst Var" "wftrms (subst_range Var)" "t = t  Var" by simp_all
    ultimately show ?case by blast 
  next
    case (Subterm t t')
    hence t_fun: "is_Fun t" by auto
    note * = Subterm.hyps(2) SMP_wf_trm[OF Subterm.hyps(1) wf_M(1)]
             Subterm.prems Subterm.IH[OF t_fun] M_SMP_repr
    show ?case by (rule SMP_D_aux3[OF *])
  next
    case (Substitution t δ)
    have wf: "wftrm t" by (metis Substitution.hyps(1) wf_M(1) SMP_wf_trm)
    hence wf': "wftrm (t  δ)" using Substitution.hyps(3) wf_trm_subst by blast
    show ?case
    proof (cases "Γ t")
      case (Var a)
      hence 1: "Γ (t  δ) = TAtom a" using Substitution.hyps(2) by (metis wt_subst_trm'') 
      then obtain c where c: "t  δ = Fun c []"
        using TAtom_term_cases[OF wf' 1] Substitution.prems by fastforce
      hence "(x. t = Var x)  t = t  δ" by (cases t) auto
      thus ?thesis
      proof
        assume t_Var: "x. t = Var x"
        then obtain x where x: "t = Var x" "δ x = Fun c []" "Γ (Var x) = TAtom a"
          using c 1 wt_subst_trm''[OF Substitution.hyps(2), of t] by force
        
        obtain m θ where m: "m  set M" "t = m  θ" and θ: "wtsubst θ" "wftrms (subst_range θ)"
          using SMP_D_aux2[OF Substitution.hyps(1) t_Var M_SMP_repr] by moura

        have "m  (θ s δ) = Fun c []" using c m(2) by auto
        thus ?thesis
          using c m(1) wt_subst_compose[OF θ(1) Substitution.hyps(2)]
                wf_trms_subst_compose[OF θ(2) Substitution.hyps(3)]
          by metis
      qed (use c Substitution.IH in auto)
    next
      case (Fun f T)
      hence 1: "Γ (t  δ) = TComp f T" using Substitution.hyps(2) by (metis wt_subst_trm'')
      have 2: "¬(f. t = Fun f [])" using Fun TComp_term_cases[OF wf] by auto
      obtain T'' where T'': "t  δ = Fun f T''"
        using 1 2 fun_type_id_eq Fun Substitution.prems
        by fastforce
      have f: "arity f > 0" "public f" using fun_type_inv[OF 1] by metis+
  
      show ?thesis
      proof (cases t)
        case (Fun g U)
        then obtain m θ where m:
            "m  set M" "wtsubst θ" "t = m  θ" "is_Fun m" "wftrms (subst_range θ)"
          using Substitution.IH Fun 2 by moura
        have "wtsubst (θ s δ)" "t  δ = m  (θ s δ)" "wftrms (subst_range (θ s δ))"
          using wt_subst_compose[OF m(2) Substitution.hyps(2)] m(3)
                wf_trms_subst_compose[OF m(5) Substitution.hyps(3)]
          by auto
        thus ?thesis using m(1,4) by metis
      next
        case (Var x)
        then obtain y where y: "y  fvset (set M)" "Γ (Var y) = Γ (Var x)"
          using SMP_D_aux1[OF Substitution.hyps(1) closed(1,3) wf_M] Fun
          by moura
        hence 3: "Γ (Var y) = TComp f T" using Var Fun Γ_Var_fst by simp
        
        obtain h V where V:
            "Fun h V  set M" "Γ (Fun h V) = Γ (Var y)" "u  set V. z. u = Var z" "distinct V"
          by (metis is_VarE is_TComp_var_instance_closedD[OF _ 3 closed(3)] y(1))
        moreover have "length T'' = length V" using 3 V(2) fun_type_length_eq 1 T'' by metis
        ultimately have TV: "T = map Γ V"
          by (metis fun_type[OF f(1)] 3 fun_type_id_eq term.inject(2))
  
        obtain θ where θ: "wtsubst θ" "wftrms (subst_range θ)" "t  δ = Fun h V  θ"
          using TComp_var_instance_wt_subst_exists 1 3 T'' TV V(2,3,4) wf'
          by (metis fun_type_id_eq)
  
        have 9: "Γ (Fun h V) = Γ (δ x)" using y(2) Substitution.hyps(2) V(2) 1 3 Var by auto
  
        show ?thesis using Var θ 9 V(1) by force
      qed
    qed
  next
    case (Ana t K T k)
    have 1: "is_Fun t" using Ana.hyps(2,3) by auto
    then obtain f U where U: "t = Fun f U" by moura
  
    have 2: "fv k  fv t" using Ana_keys_fv[OF Ana.hyps(2)] Ana.hyps(3) by auto
  
    have wf_t: "wftrm t"
      using SMP_wf_trm[OF Ana.hyps(1)] wftrm_code wf_M
      by auto
    hence wf_k: "wftrm k"
      using Ana_keys_wf'[OF Ana.hyps(2)] wftrm_code Ana.hyps(3)
      by auto
  
    have wf_M_keys: "wftrms (((set  fst  Ana) ` set M))"
    proof
      fix t assume "t  (((set  fst  Ana) ` set M))"
      then obtain s where s: "s  set M" "t  (set  fst  Ana) s" by blast
      obtain K R where KR: "Ana s = (K,R)" by (metis surj_pair)
      hence "t  set K" using s(2) by simp
      thus "wftrm t" using Ana_keys_wf'[OF KR] wf_M s(1) by blast
    qed
  
    show ?case using Ana_subst'_or_Ana_keys_subterm
    proof
      assume "t K T k. Ana t = (K, T)  k  set K  k  t"
      hence *: "k  t" using Ana.hyps(2,3) by auto
      show ?thesis by (rule SMP_D_aux3[OF * wf_t Ana.prems Ana.IH[OF 1] M_SMP_repr])
    next
      assume Ana_subst':
          "f T δ K M. Ana (Fun f T) = (K, M)  Ana (Fun f T  δ) = (K list δ, M list δ)"
  
      have "arity f > 0" using Ana_const[of f U] U Ana.hyps(2,3) by fastforce
      hence "U  []" using wf_t U unfolding wftrm_def by force
      then obtain m δ where m: "m  set M" "wtsubst δ" "wftrms (subst_range δ)" "t = m  δ" "is_Fun m"
        using Ana.IH[OF 1] U by auto
      hence "Ana (t  δ) = (K list δ,T list δ)" using Ana_subst' U Ana.hyps(2) by auto
      obtain Km Tm where Ana_m: "Ana m = (Km,Tm)" by moura
      hence "Ana (m  δ) = (Km list δ,Tm list δ)"
        using Ana_subst' U m(4) is_FunE[OF m(5)] Ana.hyps(2)
        by metis
      then obtain km where km: "km  set Km" "k = km  δ" using Ana.hyps(2,3) m(4) by auto
      then obtain θ km' where θ: "wtsubst θ" "wftrms (subst_range θ)"
          and km': "km'  set M" "km = km'  θ"
        using Ana_m m(1) has_all_wt_instances_ofD'[OF wf_M_keys wf_M closed(2), of km] by force
  
      have kθδ: "k = km'  θ s δ" "wtsubst (θ s δ)" "wftrms (subst_range (θ s δ))"
        using km(2) km' wt_subst_compose[OF θ(1) m(2)] wf_trms_subst_compose[OF θ(2) m(3)]
        by auto
  
      show ?case
      proof (cases "is_Fun km'")
        case True thus ?thesis using kθδ km'(1) by blast
      next
        case False
        note F = False
        then obtain x where x: "km' = Var x" by auto
        hence 3: "x  fvset (set M)" using fv_subset[OF km'(1)] by auto
        obtain kf kT where kf: "k = Fun kf kT" using Ana.prems by auto
        show ?thesis
        proof (cases "kT = []")
          case True thus ?thesis using kθδ(1) kθδ(2) kθδ(3) kf km'(1) by blast
        next
          case False
          hence 4: "arity kf > 0" using wf_k kf TAtom_term_cases const_type by fastforce
          then obtain kT' where kT': "Γ k = TComp kf kT'" by (simp add: fun_type kf) 
          then obtain V where V:
              "Fun kf V  set M" "Γ (Fun kf V) = Γ (Var x)" "u  set V. v. u = Var v"
              "distinct V" "is_Fun (Fun kf V)"
            using is_TComp_var_instance_closedD[OF _ _ closed(3), of x]
                  x m(2) kθδ(1) 3 wt_subst_trm''[OF kθδ(2)]
            by (metis fun_type_id_eq term.disc(2) is_VarE)
          have 5: "kT' = map Γ V"
            using fun_type[OF 4] x kT' kθδ m(2) V(2)
            by (metis term.inject(2) wt_subst_trm'')
          thus ?thesis
            using TComp_var_instance_wt_subst_exists wf_k kf 4 V(3,4) kT' V(1,5)
            by metis
        qed
      qed
    qed
  qed
qed

lemma SMP_D':
  fixes M
  defines "δ  var_rename (max_var_set (fvset (set M)))"
  assumes M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
    and s: "s  SMP (set M)" "is_Fun s" "f. s = Fun f []"
    and t: "t  SMP (set M)" "is_Fun t" "f. t = Fun f []"
  obtains σ s0 θ t0
  where "wtsubst σ" "wftrms (subst_range σ)" "s0  set M" "is_Fun s0" "s = s0  σ" "Γ s = Γ s0"
    and "wtsubst θ" "wftrms (subst_range θ)" "t0  set M" "is_Fun t0" "t = t0  δ  θ" "Γ t = Γ t0"
proof -
  obtain σ s0 where
      s0: "wtsubst σ" "wftrms (subst_range σ)" "s0  set M" "s = s0  σ" "is_Fun s0"
    using s(3) SMP_D[OF s(1,2) M_SMP_repr] unfolding δ_def by metis

  obtain θ t0 where t0:
      "wtsubst θ" "wftrms (subst_range θ)" "t0  set M" "t = t0  δ  θ" "is_Fun t0"
    using t(3) SMP_D[OF t(1,2) M_SMP_repr] var_rename_wt'[of _ t]
          wf_trms_subst_compose_Var_range(1)[OF _ var_rename_is_renaming(2)]
    unfolding δ_def by metis

  have "Γ s = Γ s0" "Γ t = Γ (t0  δ)" "Γ (t0  δ) = Γ t0"
    using s0 t0 wt_subst_trm'' by (metis, metis, metis δ_def var_rename_wt(1))
  thus ?thesis using s0 t0 that by simp
qed

lemma SMP_D'':
  fixes t::"('fun, ('fun, 'atom) term × nat) term"
  assumes t_SMP: "t  SMP (set M)"
    and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
  shows "m  set M. δ. wtsubst δ  wftrms (subst_range δ)  t = m  δ"
proof (cases "(x. t = Var x)  (c. t = Fun c [])")
  case True
  have M_wf: "wftrms (set M)" 
      and M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
      and M_subterms_cl: "has_all_wt_instances_of Γ (subtermsset (set M)) (set M)"
      and M_Ana_cl: "has_all_wt_instances_of Γ (((set  fst  Ana) ` set M)) (set M)"
    using finite_SMP_representationD[OF M_SMP_repr] by blast+

  have M_Ana_wf: "wftrms ( ((set  fst  Ana) ` set M))"
  proof
    fix k assume "k  ((set  fst  Ana) ` set M)"
    then obtain m where m: "m  set M" "k  set (fst (Ana m))" by force
    thus "wftrm k" using M_wf Ana_keys_wf'[of m "fst (Ana m)" _ k] surjective_pairing by blast
  qed

  show ?thesis using True
  proof
    assume "x. t = Var x"
    then obtain x y where x: "t = Var x" and y: "y  fvset (set M)" "Γ (Var y) = Γ (Var x)"
      using SMP_D_aux1[OF t_SMP M_subterms_cl M_var_inst_cl M_wf] by fastforce
    then obtain m δ where m: "m  set M" "m  δ = Var y" and δ: "wtsubst δ"
      using has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl, of "Var y"]
            vars_iff_subtermeq_set[of y "set M"]
      by fastforce

    obtain z where z: "m = Var z" using m(2) by (cases m) auto

    define θ where "θ  Var(z := Var x)::('fun, ('fun, 'atom) term × nat) subst"

    have "Γ (Var z) = Γ (Var x)" using y(2) m(2) z wt_subst_trm''[OF δ, of m] by argo
    hence "wtsubst θ" "wftrms (subst_range θ)" unfolding θ_def wtsubst_def by force+
    moreover have "t = m  θ" using x z unfolding θ_def by simp
    ultimately show ?thesis using m(1) by blast
  qed (use SMP_D[OF t_SMP _ M_SMP_repr] in blast)
qed (use SMP_D[OF t_SMP _ M_SMP_repr] in blast)
end

lemma tfrset_if_comp_tfrset:
  assumes "comp_tfrset arity Ana Γ M"
  shows "tfrset (set M)"
proof -
  let  = "var_rename (max_var_set (fvset (set M)))"
  have M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
    by (metis comp_tfrset_def assms)

  have M_finite: "finite (set M)"
    using assms card_gt_0_iff unfolding comp_tfrset_def by blast

  show ?thesis
  proof (unfold tfrset_def; intro ballI impI)
    fix s t assume "s  SMP (set M) - Var`𝒱" "t  SMP (set M) - Var`𝒱"
    hence st: "s  SMP (set M)" "is_Fun s" "t  SMP (set M)" "is_Fun t" by auto
    have "¬(δ. Unifier δ s t)" when st_type_neq: "Γ s  Γ t"
    proof (cases "f. s = Fun f []  t = Fun f []")
      case False
      then obtain σ s0 θ t0 where
            s0: "s0  set M" "is_Fun s0" "s = s0  σ" "Γ s = Γ s0"
        and t0: "t0  set M" "is_Fun t0" "t = t0    θ" "Γ t = Γ t0"
        using SMP_D'[OF M_SMP_repr st(1,2) _ st(3,4)] by metis
      hence "¬(δ. Unifier δ s0 (t0  ))"
        using assms mgu_None_is_subst_neq st_type_neq wt_subst_trm''[OF var_rename_wt(1)]
        unfolding comp_tfrset_def Let_def by metis
      thus ?thesis
        using vars_term_disjoint_imp_unifier[OF var_rename_fv_set_disjoint[OF M_finite]] s0(1) t0(1)
        unfolding s0(3) t0(3) by (metis (no_types, hide_lams) subst_subst_compose)
    qed (use st_type_neq st(2,4) in auto)
    thus "Γ s = Γ t" when "δ. Unifier δ s t" by (metis that)
  qed
qed

lemma tfrset_if_comp_tfrset':
  assumes "let N = SMP0 Ana Γ M in set M  set N  comp_tfrset arity Ana Γ N"
  shows "tfrset (set M)"
by (rule tfr_subset(2)[
          OF tfrset_if_comp_tfrset[OF conjunct2[OF assms[unfolded Let_def]]]
             conjunct1[OF assms[unfolded Let_def]]])

lemma tfrstp_is_comp_tfrstp: "tfrstp a = comp_tfrstp Γ a"
proof (cases a)
  case (Equality ac t t')
  thus ?thesis
    using mgu_always_unifies[of t _ t'] mgu_gives_MGU[of t t']
    by auto
next
  case (Inequality X F)
  thus ?thesis
    using tfrstp.simps(2)[of X F]
          comp_tfrstp.simps(2)[of Γ X F]
          Fun_range_case(2)[of "subtermsset (trmspairs F)"] 
    unfolding is_Var_def
    by auto
qed auto

lemma tfrst_if_comp_tfrst:
  assumes "comp_tfrst arity Ana Γ M S"
  shows "tfrst S"
unfolding tfrst_def
proof
  have comp_tfrset_M: "comp_tfrset arity Ana Γ M"
    using assms unfolding comp_tfrst_def by blast
  
  have wftrms_M: "wftrms (set M)"
      and wftrms_S: "wftrms (trmsst S)"
      and S_trms_instance_M: "has_all_wt_instances_of Γ (trmsst S) (set M)"
    using assms wftrm_code trms_listst_is_trmsst
    unfolding comp_tfrst_def comp_tfrset_def finite_SMP_representation_def list_all_iff
    by blast+

  show "tfrset (trmsst S)"
    using tfr_subset(3)[OF tfrset_if_comp_tfrset[OF comp_tfrset_M] SMP_SMP_subset]
          SMP_I'[OF wftrms_S wftrms_M S_trms_instance_M]
    by blast

  have "list_all (comp_tfrstp Γ) S" by (metis assms comp_tfrst_def)
  thus "list_all tfrstp S" by (induct S) (simp_all add: tfrstp_is_comp_tfrstp)
qed

lemma tfrst_if_comp_tfrst':
  assumes "comp_tfrst arity Ana Γ (SMP0 Ana Γ (trms_listst S)) S"
  shows "tfrst S"
by (rule tfrst_if_comp_tfrst[OF assms])



subsubsection ‹Lemmata for Checking Ground SMP (GSMP) Disjointness›
context
begin
private lemma ground_SMP_disjointI_aux1:
  fixes M::"('fun, ('fun, 'atom) term × nat) term set"
  assumes f_def: "f  λM. {t  δ | t δ. t  M  wtsubst δ  wftrms (subst_range δ)  fv (t  δ) = {}}"
    and g_def: "g  λM. {t  M. fv t = {}}"
  shows "f (SMP M) = g (SMP M)"
proof
  have "t  f (SMP M)" when t: "t  SMP M" "fv t = {}" for t
  proof -
    define δ where "δ  Var::('fun, ('fun, 'atom) term × nat) subst"
    have "wtsubst δ" "wftrms (subst_range δ)" "t = t  δ"
      using subst_apply_term_empty[of t] that(2) wt_subst_Var wf_trm_subst_range_Var
      unfolding δ_def by auto
    thus ?thesis using SMP.Substitution[OF t(1), of δ] t(2) unfolding f_def by fastforce
  qed
  thus "g (SMP M)  f (SMP M)" unfolding g_def by blast
qed (use f_def g_def in blast)

private lemma ground_SMP_disjointI_aux2:
  fixes M::"('fun, ('fun, 'atom) term × nat) term list"
  assumes f_def: "f  λM. {t  δ | t δ. t  M  wtsubst δ  wftrms (subst_range δ)  fv (t  δ) = {}}"
    and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
  shows "f (set M) = f (SMP (set M))"
proof
  have M_wf: "wftrms (set M)" 
      and M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
      and M_subterms_cl: "has_all_wt_instances_of Γ (subtermsset (set M)) (set M)"
      and M_Ana_cl: "has_all_wt_instances_of Γ (((set  fst  Ana) ` set M)) (set M)"
    using finite_SMP_representationD[OF M_SMP_repr] by blast+

  show "f (SMP (set M))  f (set M)"
  proof
    fix t assume "t  f (SMP (set M))"
    then obtain s δ where s: "t = s  δ" "s  SMP (set M)" "fv (s  δ) = {}"
        and δ: "wtsubst δ" "wftrms (subst_range δ)"
      unfolding f_def by blast

    have t_wf: "wftrm t" using SMP_wf_trm[OF s(2) M_wf] s(1) wf_trm_subst[OF δ(2)] by blast 

    obtain m θ where m: "m  set M" "s = m  θ" and θ: "wtsubst θ" "wftrms (subst_range θ)"
      using SMP_D''[OF s(2) M_SMP_repr] by blast

    have "t = m  (θ s δ)" "fv (m  (θ s δ)) = {}" using s(1,3) m(2) by simp_all
    thus "t  f (set M)"
      using m(1) wt_subst_compose[OF θ(1) δ(1)] wf_trms_subst_compose[OF θ(2) δ(2)]
      unfolding f_def by blast
  qed
qed (auto simp add: f_def)

private lemma ground_SMP_disjointI_aux3:
  fixes A B C::"('fun, ('fun, 'atom) term × nat) term set"
  defines "P  λt s. δ. wtsubst δ  wftrms (subst_range δ)  Unifier δ t s"
  assumes f_def: "f  λM. {t  δ | t δ. t  M  wtsubst δ  wftrms (subst_range δ)  fv (t  δ) = {}}"
    and Q_def: "Q  λt. intruder_synth' public arity {} t"
    and R_def: "R  λt. u  C. is_wt_instance_of_cond Γ t u"
    and AB: "wftrms A" "wftrms B" "fvset A  fvset B = {}"
    and C: "wftrms C"
    and ABC: "t  A. s  B. P t s  (Q t  Q s)  (R t  R s)"
  shows "f A  f B  f C  {m. {} c m}"
proof
  fix t assume "t  f A  f B"
  then obtain ta tb δa δb where
          ta: "t = ta  δa" "ta  A" "wtsubst δa" "wftrms (subst_range δa)" "fv (ta  δa) = {}"
      and tb: "t = tb  δb" "tb  B" "wtsubst δb" "wftrms (subst_range δb)" "fv (tb  δb) = {}"
    unfolding f_def by blast

  have ta_tb_wf: "wftrm ta" "wftrm tb" "fv ta  fv tb = {}" "Γ ta = Γ tb"
    using ta(1,2) tb(1,2) AB fv_subset_subterms
          wt_subst_trm''[OF ta(3), of ta] wt_subst_trm''[OF tb(3), of tb]
    by (fast, fast, blast, simp)

  obtain θ where θ: "Unifier θ ta tb" "wtsubst θ" "wftrms (subst_range θ)"
    using vars_term_disjoint_imp_unifier[OF ta_tb_wf(3), of δa δb]
          ta(1) tb(1) wt_Unifier_if_Unifier[OF ta_tb_wf(1,2,4)]
    by blast
  hence "(Q ta  Q tb)  (R ta  R tb)" using ABC ta(2) tb(2) unfolding P_def by blast+
  thus "t  f C  {m. {} c m}"
  proof
    show "Q ta  Q tb  ?thesis"
      using ta(1) pgwt_ground[of ta] pgwt_is_empty_synth[of ta] subst_ground_ident[of ta δa]
      unfolding Q_def f_def intruder_synth_code[symmetric] by simp
  next
    assume "R ta  R tb"
    then obtain ua σa where ua: "ta = ua  σa" "ua  C" "wtsubst σa" "wftrms (subst_range σa)"
      using θ ABC ta_tb_wf(1,2) ta(2) tb(2) C is_wt_instance_of_condD'
      unfolding P_def R_def by metis
  
    have "t = ua  (σa s δa)" "fv t = {}"
      using ua(1) ta(1,5) tb(1,5) by auto
    thus ?thesis
      using ua(2) wt_subst_compose[OF ua(3) ta(3)] wf_trms_subst_compose[OF ua(4) ta(4)]
      unfolding f_def by blast
  qed
qed

lemma ground_SMP_disjointI:
  fixes A B::"('fun, ('fun, 'atom) term × nat) term list" and C
  defines "f  λM. {t  δ | t δ. t  M  wtsubst δ  wftrms (subst_range δ)  fv (t  δ) = {}}"
    and "g  λM. {t  M. fv t = {}}"
    and "Q  λt. intruder_synth' public arity {} t"
    and "R  λt. u  C. is_wt_instance_of_cond Γ t u"
  assumes AB_fv_disj: "fvset (set A)  fvset (set B) = {}"
    and A_SMP_repr: "finite_SMP_representation arity Ana Γ A"
    and B_SMP_repr: "finite_SMP_representation arity Ana Γ B"
    and C_wf: "wftrms C"
    and ABC: "t  set A. s  set B. Γ t = Γ s  mgu t s  None  (Q t  Q s)  (R t  R s)"
  shows "g (SMP (set A))  g (SMP (set B))  f C  {m. {} c m}"
proof -
  have AB_wf: "wftrms (set A)" "wftrms (set B)"
    using A_SMP_repr B_SMP_repr
    unfolding finite_SMP_representation_def wftrm_code list_all_iff
    by blast+

  let ?P = "λt s. δ. wtsubst δ  wftrms (subst_range δ)  Unifier δ t s"
  have ABC': "t  set A. s  set B. ?P t s  (Q t  Q s)  (R t  R s)"
    by (metis (no_types) ABC mgu_None_is_subst_neq wt_subst_trm'')

  show ?thesis
    using ground_SMP_disjointI_aux1[OF f_def g_def, of "set A"]
          ground_SMP_disjointI_aux1[OF f_def g_def, of "set B"]
          ground_SMP_disjointI_aux2[OF f_def A_SMP_repr]
          ground_SMP_disjointI_aux2[OF f_def B_SMP_repr]
          ground_SMP_disjointI_aux3[OF f_def Q_def R_def AB_wf AB_fv_disj C_wf ABC']
    by argo
qed

end

end

end

Theory Typing_Result

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Typing_Result.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹The Typing Result›
text ‹\label{sec:Typing-Result}›

theory Typing_Result
imports Typed_Model
begin

subsection ‹The Typing Result for the Composition-Only Intruder›
context typed_model
begin

subsubsection ‹Well-typedness and Type-Flaw Resistance Preservation›
context
begin

private lemma LI_preserves_tfr_stp_all_single:
  assumes "(S,θ)  (S',θ')" "wfconstr S θ" "wtsubst θ"
  and "list_all tfrstp S" "tfrset (trmsst S)" "wftrms (trmsst S)"
  shows "list_all tfrstp S'"
using assms
proof (induction rule: LI_rel.induct)
  case (Compose S X f S' θ)
  hence "list_all tfrstp S" "list_all tfrstp S'" by simp_all
  moreover have "list_all tfrstp (map Send X)" by (induct X) auto
  ultimately show ?case by simp
next
  case (Unify S f Y δ X S' θ)
  hence "list_all tfrstp (S@S')" by simp

  have "fvst (S@Send (Fun f X)#S')  bvarsst (S@S') = {}"
    using Unify.prems(1) by (auto simp add: wfconstr_def)
  moreover have "fv (Fun f X)  fvst (S@Send (Fun f X)#S')" by auto
  moreover have "fv (Fun f Y)  fvst (S@Send (Fun f X)#S')"
    using Unify.hyps(2) fv_subset_if_in_strand_ik'[of "Fun f Y" S] by force
  ultimately have bvars_disj:
      "bvarsst (S@S')  fv (Fun f X) = {}" "bvarsst (S@S')  fv (Fun f Y) = {}"
    by blast+

  have "wftrm (Fun f X)" using Unify.prems(5) by simp
  moreover have "wftrm (Fun f Y)"
  proof -
    obtain x where "x  set S" "Fun f Y  subtermsset (trmsstp x)" "wftrms (trmsstp x)"
      using Unify.hyps(2) Unify.prems(5) by force+
    thus ?thesis using wf_trm_subterm by auto
  qed
  moreover have
      "Fun f X  SMP (trmsst (S@Send (Fun f X)#S'))" "Fun f Y  SMP (trmsst (S@Send (Fun f X)#S'))"
    using SMP_append[of S "Send (Fun f X)#S'"] SMP_Cons[of "Send (Fun f X)" S']
          SMP_ikI[OF Unify.hyps(2)]
    by auto
  hence "Γ (Fun f X) = Γ (Fun f Y)"
    using Unify.prems(4) mgu_gives_MGU[OF Unify.hyps(3)[symmetric]]
    unfolding tfrset_def by blast
  ultimately have "wtsubst δ" using mgu_wt_if_same_type[OF Unify.hyps(3)[symmetric]] by metis
  moreover have "wftrms (subst_range δ)"
    using mgu_wf_trm[OF Unify.hyps(3)[symmetric] ‹wftrm (Fun f X) ‹wftrm (Fun f Y)]
    by (metis wf_trm_subst_range_iff)
  moreover have "bvarsst (S@S')  range_vars δ = {}"
    using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] bvars_disj by fast
  ultimately show ?case using tfr_stp_all_wt_subst_apply[OF ‹list_all tfrstp (S@S')] by metis
next
  case (Equality S δ t t' a S' θ)
  have "list_all tfrstp (S@S')" "Γ t = Γ t'"
    using tfr_stp_all_same_type[of S a t t' S']
          tfr_stp_all_split(5)[of S _ S']
          MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]]
          Equality.prems(3)
    by blast+
  moreover have "wftrm t" "wftrm t'" using Equality.prems(5) by auto
  ultimately have "wtsubst δ"
    using mgu_wt_if_same_type[OF Equality.hyps(2)[symmetric]]
    by metis
  moreover have "wftrms (subst_range δ)"
    using mgu_wf_trm[OF Equality.hyps(2)[symmetric] ‹wftrm t ‹wftrm t']
    by (metis wf_trm_subst_range_iff)
  moreover have "fvst (S@Equality a t t'#S')  bvarsst (S@Equality a t t'#S') = {}"
    using Equality.prems(1) by (auto simp add: wfconstr_def)
  hence "bvarsst (S@S')  fv t = {}" "bvarsst (S@S')  fv t' = {}" by auto
  hence "bvarsst (S@S')  range_vars δ = {}"
    using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] by fast
  ultimately show ?case using tfr_stp_all_wt_subst_apply[OF ‹list_all tfrstp (S@S')] by metis
qed

private lemma LI_in_SMP_subset_single:
  assumes "(S,θ)  (S',θ')" "wfconstr S θ" "wtsubst θ"
          "tfrset (trmsst S)" "wftrms (trmsst S)" "list_all tfrstp S"
  and "trmsst S  SMP M"
  shows "trmsst S'  SMP M"
using assms
proof (induction rule: LI_rel.induct)
  case (Compose S X f S' θ)
  hence "SMP (trmsst [Send (Fun f X)])  SMP M"
  proof -
    have "SMP (trmsst [Send (Fun f X)])  SMP (trmsst (S@Send (Fun f X)#S'))"
      using trmsst_append SMP_mono by auto
    thus ?thesis
      using SMP_union[of "trmsst (S@Send (Fun f X)#S')" M]
            SMP_subset_union_eq[OF Compose.prems(6)]
      by auto
  qed
  thus ?case using Compose.prems(6) by auto
next
  case (Unify S f Y δ X S' θ)
  have "Fun f X  SMP (trmsst (S@Send (Fun f X)#S'))" by auto
  moreover have "MGU δ (Fun f X) (Fun f Y)"
    by (metis mgu_gives_MGU[OF Unify.hyps(3)[symmetric]])
  moreover have
        "x. x  set S  wftrms (trmsstp x)" "wftrm (Fun f X)"
    using Unify.prems(4) by force+
  moreover have "Fun f Y  SMP (trmsst (S@Send (Fun f X)#S'))"
    by (meson SMP_ikI Unify.hyps(2) contra_subsetD ik_append_subset(1))
  ultimately have "wftrm (Fun f Y)" "Γ (Fun f X) = Γ (Fun f Y)"
    using ikst_subterm_exD[OF ‹Fun f Y  ikst S] ‹tfrset (trmsst (S@Send (Fun f X)#S'))
    unfolding tfrset_def by (metis (full_types) SMP_wf_trm Unify.prems(4), blast)
  hence "wtsubst δ" by (metis mgu_wt_if_same_type[OF Unify.hyps(3)[symmetric] ‹wftrm (Fun f X)])
  moreover have "wftrms (subst_range δ)"
    using mgu_wf_trm[OF Unify.hyps(3)[symmetric] ‹wftrm (Fun f X) ‹wftrm (Fun f Y)] by simp
  ultimately have "trmsst ((S@Send (Fun f X)#S') st δ)  SMP M"
    using SMP.Substitution Unify.prems(6) wt_subst_SMP_subset by metis
  thus ?case by auto
next
  case (Equality S δ t t' a S' θ)
  hence "Γ t = Γ t'"
    using tfr_stp_all_same_type MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]]
    by metis
  moreover have "t  SMP (trmsst (S@Equality a t t'#S'))" "t'  SMP (trmsst (S@Equality a t t'#S'))"
    using Equality.prems(1) by auto
  moreover have "MGU δ t t'" using mgu_gives_MGU[OF Equality.hyps(2)[symmetric]] by metis
  moreover have "x. x  set S  wftrms (trmsstp x)" "wftrm t" "wftrm t'"
    using Equality.prems(4) by force+
  ultimately have "wtsubst δ" by (metis mgu_wt_if_same_type[OF Equality.hyps(2)[symmetric] ‹wftrm t])
  moreover have "wftrms (subst_range δ)"
    using mgu_wf_trm[OF Equality.hyps(2)[symmetric] ‹wftrm t ‹wftrm t'] by simp
  ultimately have "trmsst ((S@Equality a t t'#S') st δ)  SMP M"
    using SMP.Substitution Equality.prems wt_subst_SMP_subset by metis
  thus ?case by auto
qed

private lemma LI_preserves_tfr_single:
  assumes "(S,θ)  (S',θ')" "wfconstr S θ" "wtsubst θ" "wftrms (subst_range θ)"
          "tfrset (trmsst S)" "wftrms (trmsst S)"
          "list_all tfrstp S"
  shows "tfrset (trmsst S')  wftrms (trmsst S')"
using assms
proof (induction rule: LI_rel.induct)
  case (Compose S X f S' θ)
  let ?SMPmap = "SMP (trmsst (S@map Send X@S')) - (Var`𝒱)"
  have "?SMPmap  SMP (trmsst (S@Send (Fun f X)#S')) - (Var`𝒱)"
    using SMP_fun_map_snd_subset[of X f]
          SMP_append[of "map Send X" S'] SMP_Cons[of "Send (Fun f X)" S']
          SMP_append[of S "Send (Fun f X)#S'"] SMP_append[of S "map Send X@S'"]
    by auto
  hence "s  ?SMPmap. t  ?SMPmap. (δ. Unifier δ s t)  Γ s = Γ t"
    using Compose unfolding tfrset_def by (meson subsetCE)
  thus ?case
    using LI_preserves_trm_wf[OF r_into_rtrancl[OF LI_rel.Compose[OF Compose.hyps]], of S']
          Compose.prems(5)
    unfolding tfrset_def by blast
next
  case (Unify S f Y δ X S' θ)
  let ?SMPδ = "SMP (trmsst (S@S' st δ)) - (Var`𝒱)"

  have "SMP (trmsst (S@S' st δ))  SMP (trmsst (S@Send (Fun f X)#S'))"
  proof
    fix s assume "s  SMP (trmsst (S@S' st δ))" thus "s  SMP (trmsst (S@Send (Fun f X)#S'))"
      using LI_in_SMP_subset_single[
              OF LI_rel.Unify[OF Unify.hyps] Unify.prems(1,2,4,5,6)
                 MP_subset_SMP(2)[of "S@Send (Fun f X)#S'"]]
      by (metis SMP_union SMP_subset_union_eq Un_iff)
  qed
  hence "s  ?SMPδ. t  ?SMPδ. (δ. Unifier δ s t)  Γ s = Γ t"
    using Unify.prems(4) unfolding tfrset_def by (meson Diff_iff subsetCE)
  thus ?case
    using LI_preserves_trm_wf[OF r_into_rtrancl[OF LI_rel.Unify[OF Unify.hyps]], of S']
          Unify.prems(5)
    unfolding tfrset_def by blast
next
  case (Equality S δ t t' a S' θ)
  let ?SMPδ = "SMP (trmsst (S@S' st δ)) - (Var`𝒱)"

  have "SMP (trmsst (S@S' st δ))  SMP (trmsst (S@Equality a t t'#S'))"
  proof
    fix s assume "s  SMP (trmsst (S@S' st δ))" thus "s  SMP (trmsst (S@Equality a t t'#S'))"
      using LI_in_SMP_subset_single[
              OF LI_rel.Equality[OF Equality.hyps] Equality.prems(1,2,4,5,6)
                 MP_subset_SMP(2)[of "S@Equality a t t'#S'"]]
      by (metis SMP_union SMP_subset_union_eq Un_iff)
  qed
  hence "s  ?SMPδ. t  ?SMPδ. (δ. Unifier δ s t)  Γ s = Γ t"
    using Equality.prems unfolding tfrset_def by (meson Diff_iff subsetCE)
  thus ?case
    using LI_preserves_trm_wf[OF r_into_rtrancl[OF LI_rel.Equality[OF Equality.hyps]], of _ S']
          Equality.prems
    unfolding tfrset_def by blast
qed

private lemma LI_preserves_welltypedness_single:
  assumes "(S,θ)  (S',θ')" "wfconstr S θ" "wtsubst θ" "wftrms (subst_range θ)"
  and "tfrset (trmsst S)" "wftrms (trmsst S)" "list_all tfrstp S"
  shows "wtsubst θ'  wftrms (subst_range θ')"
using assms
proof (induction rule: LI_rel.induct)
  case (Unify S f Y δ X S' θ)
  have "wftrm (Fun f X)" using Unify.prems(5) unfolding tfrset_def by simp
  moreover have "wftrm (Fun f Y)"
  proof -
    obtain x where "x  set S" "Fun f Y  subtermsset (trmsstp x)" "wftrms (trmsstp x)"
      using Unify.hyps(2) Unify.prems(5) unfolding tfrset_def by force
    thus ?thesis using wf_trm_subterm by auto
  qed
  moreover have
      "Fun f X  SMP (trmsst (S@Send (Fun f X)#S'))" "Fun f Y  SMP (trmsst (S@Send (Fun f X)#S'))"
    using SMP_append[of S "Send (Fun f X)#S'"] SMP_Cons[of "Send (Fun f X)" S']
          SMP_ikI[OF Unify.hyps(2)]
    by auto
  hence "Γ (Fun f X) = Γ (Fun f Y)"
    using Unify.prems(4) mgu_gives_MGU[OF Unify.hyps(3)[symmetric]]
    unfolding tfrset_def by blast
  ultimately have "wtsubst δ" using mgu_wt_if_same_type[OF Unify.hyps(3)[symmetric]] by metis

  have "wftrms (subst_range δ)"
    by (meson mgu_wf_trm[OF Unify.hyps(3)[symmetric] ‹wftrm (Fun f X) ‹wftrm (Fun f Y)]
              wf_trm_subst_range_iff)
  hence "wftrms (subst_range (θ s δ))"
    using wf_trm_subst_range_iff wf_trm_subst ‹wftrms (subst_range θ)
    unfolding subst_compose_def
    by (metis (no_types, lifting))
  thus ?case by (metis wt_subst_compose[OF ‹wtsubst θ ‹wtsubst δ])
next
  case (Equality S δ t t' a S' θ)
  have "wftrm t" "wftrm t'" using Equality.prems(5) by simp_all
  moreover have "Γ t = Γ t'"
    using ‹list_all tfrstp (S@Equality a t t'#S')
          MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]]
    by auto
  ultimately have "wtsubst δ" using mgu_wt_if_same_type[OF Equality.hyps(2)[symmetric]] by metis

  have "wftrms (subst_range δ)"
    by (meson mgu_wf_trm[OF Equality.hyps(2)[symmetric] ‹wftrm t ‹wftrm t'] wf_trm_subst_range_iff)
  hence "wftrms (subst_range (θ s δ))"
    using wf_trm_subst_range_iff wf_trm_subst ‹wftrms (subst_range θ)
    unfolding subst_compose_def
    by (metis (no_types, lifting))
  thus ?case by (metis wt_subst_compose[OF ‹wtsubst θ ‹wtsubst δ])
qed metis

lemma LI_preserves_welltypedness:
  assumes "(S,θ) * (S',θ')" "wfconstr S θ" "wtsubst θ" "wftrms (subst_range θ)"
    and "tfrset (trmsst S)" "wftrms (trmsst S)" "list_all tfrstp S"
  shows "wtsubst θ'" (is "?A θ'")
    and "wftrms (subst_range θ')" (is "?B θ'")
proof -
  have "?A θ'  ?B θ'" using assms
  proof (induction S θ rule: converse_rtrancl_induct2)
    case (step S1 θ1 S2 θ2)
    hence "?A θ2  ?B θ2" using LI_preserves_welltypedness_single by presburger
    moreover have "wfconstr S2 θ2"
      by (fact LI_preserves_wellformedness[OF r_into_rtrancl[OF step.hyps(1)] step.prems(1)])
    moreover have "tfrset (trmsst S2)" "wftrms (trmsst S2)"
      using LI_preserves_tfr_single[OF step.hyps(1)] step.prems by presburger+
    moreover have "list_all tfrstp S2"
      using LI_preserves_tfr_stp_all_single[OF step.hyps(1)] step.prems by fastforce
    ultimately show ?case using step.IH by presburger
  qed simp
  thus "?A θ'" "?B θ'" by simp_all
qed

lemma LI_preserves_tfr:
  assumes "(S,θ) * (S',θ')" "wfconstr S θ" "wtsubst θ" "wftrms (subst_range θ)"
    and "tfrset (trmsst S)" "wftrms (trmsst S)" "list_all tfrstp S"
  shows "tfrset (trmsst S')" (is "?A S'")
    and "wftrms (trmsst S')" (is "?B S'")
    and "list_all tfrstp S'" (is "?C S'")
proof -
  have "?A S'  ?B S'  ?C S'" using assms
  proof (induction S θ rule: converse_rtrancl_induct2)
    case (step S1 θ1 S2 θ2)
    have "wfconstr S2 θ2" "tfrset (trmsst S2)" "wftrms (trmsst S2)" "list_all tfrstp S2"
      using LI_preserves_wellformedness[OF r_into_rtrancl[OF step.hyps(1)] step.prems(1)]
            LI_preserves_tfr_single[OF step.hyps(1) step.prems(1,2)]
            LI_preserves_tfr_stp_all_single[OF step.hyps(1) step.prems(1,2)]
            step.prems(3,4,5,6)
      by metis+
    moreover have "wtsubst θ2" "wftrms (subst_range θ2)"
      using LI_preserves_welltypedness[OF r_into_rtrancl[OF step.hyps(1)] step.prems]
      by simp_all
    ultimately show ?case using step.IH by presburger
  qed blast
  thus "?A S'" "?B S'" "?C S'" by simp_all
qed
end

subsubsection ‹Simple Constraints are Well-typed Satisfiable›
text ‹Proving the existence of a well-typed interpretation›
context
begin
lemma wt_interpretation_exists:
  obtains ::"('fun,'var) subst"
  where "interpretationsubst " "wtsubst " "subst_range   public_ground_wf_terms"
proof
  define  where " = (λx. (SOME t. Γ (Var x) = Γ t  public_ground_wf_term t))"

  { fix x t assume " x = t"
    hence "Γ (Var x) = Γ t  public_ground_wf_term t"
      using someI_ex[of "λt. Γ (Var x) = Γ t  public_ground_wf_term t",
                     OF type_pgwt_inhabited[of "Var x"]]
      unfolding ℐ_def wftrm_def by simp
  } hence props: " v = t  Γ (Var v) = Γ t  public_ground_wf_term t" for v t by metis

  have " v  Var v" for v using props pgwt_ground by (simp add: empty_fv_not_var)
  hence "subst_domain  = UNIV" by auto
  moreover have "ground (subst_range )" by (simp add: props pgwt_ground)
  ultimately show "interpretationsubst " by metis
  show "wtsubst " unfolding wtsubst_def using props by simp
  show "subst_range   public_ground_wf_terms" by (auto simp add: props)
qed

lemma wt_grounding_subst_exists:
  "θ. wtsubst θ  wftrms (subst_range θ)  fv (t  θ) = {}"
proof -
  obtain θ where θ: "interpretationsubst θ" "wtsubst θ" "subst_range θ  public_ground_wf_terms"
    using wt_interpretation_exists by blast
  show ?thesis using pgwt_wellformed interpretation_grounds[OF θ(1)] θ(2,3) by blast
qed

private fun fresh_pgwt::"'fun set  ('fun,'atom) term_type  ('fun,'var) term"  where
  "fresh_pgwt S (TAtom a) =
    Fun (SOME c. c  S  Γ (Fun c []) = TAtom a  public c) []"
| "fresh_pgwt S (TComp f T) = Fun f (map (fresh_pgwt S) T)"

private lemma fresh_pgwt_same_type:
  assumes "finite S" "wftrm t"
  shows "Γ (fresh_pgwt S (Γ t)) = Γ t"
proof -
  let ?P = "λτ::('fun,'atom) term_type. wftrm τ  (f T. TComp f T  τ  0 < arity f)"
  { fix τ assume "?P τ" hence "Γ (fresh_pgwt S τ) = τ"
    proof (induction τ)
      case (Var a)
      let ?P = "λc. c  S  Γ (Fun c []) = Var a  public c"
      let ?Q = "λc. Γ (Fun c []) = Var a  public c"
      have " {c. ?Q c} - S = {c. ?P c}" by auto
      hence "infinite {c. ?P c}"
        using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]]
        by metis
      hence "c. ?P c" using not_finite_existsD by blast
      thus ?case using someI_ex[of ?P] by auto
    next
      case (Fun f T)
      have f: "0 < arity f" using Fun.prems fun_type_inv by auto
      have "t. t  set T  ?P t"
        using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm
        by metis
      hence "t. t  set T  Γ (fresh_pgwt S t) = t" using Fun.prems Fun.IH by auto
      hence "map Γ (map (fresh_pgwt S) T) = T"  by (induct T) auto
      thus ?case using fun_type[OF f] by simp
    qed
  } thus ?thesis using assms(1) Γ_wf'[OF assms(2)] Γ_wf(1) by auto
qed

private lemma fresh_pgwt_empty_synth:
  assumes "finite S" "wftrm t"
  shows "{} c fresh_pgwt S (Γ t)"
proof -
  let ?P = "λτ::('fun,'atom) term_type. wftrm τ  (f T. TComp f T  τ  0 < arity f)"
  { fix τ assume "?P τ" hence "{} c fresh_pgwt S τ"
    proof (induction τ)
      case (Var a)
      let ?P = "λc. c  S  Γ (Fun c []) = Var a  public c"
      let ?Q = "λc. Γ (Fun c []) = Var a  public c"
      have " {c. ?Q c} - S = {c. ?P c}" by auto
      hence "infinite {c. ?P c}"
        using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]]
        by metis
      hence "c. ?P c" using not_finite_existsD by blast
      thus ?case
        using someI_ex[of ?P] intruder_synth.ComposeC[of "[]" _ "{}"] const_type_inv
        by auto
    next
      case (Fun f T)
      have f: "0 < arity f" "length T = arity f" "public f"
        using Fun.prems fun_type_inv unfolding wftrm_def by auto
      have "t. t  set T  ?P t"
        using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm
        by metis
      hence "t. t  set T  {} c fresh_pgwt S t" using Fun.prems Fun.IH by auto
      moreover have "length (map (fresh_pgwt S) T) = arity f" using f(2) by auto
      ultimately show ?case using intruder_synth.ComposeC[of "map (fresh_pgwt S) T" f] f by auto
    qed
  } thus ?thesis using assms(1) Γ_wf'[OF assms(2)] Γ_wf(1) by auto
qed

private lemma fresh_pgwt_has_fresh_const:
  assumes "finite S" "wftrm t"
  obtains c where "Fun c []  fresh_pgwt S (Γ t)" "c  S"
proof -
  let ?P = "λτ::('fun,'atom) term_type. wftrm τ  (f T. TComp f T  τ  0 < arity f)"
  { fix τ assume "?P τ" hence "c. Fun c []  fresh_pgwt S τ  c  S"
    proof (induction τ)
      case (Var a)
      let ?P = "λc. c  S  Γ (Fun c []) = Var a  public c"
      let ?Q = "λc. Γ (Fun c []) = Var a  public c"
      have " {c. ?Q c} - S = {c. ?P c}" by auto
      hence "infinite {c. ?P c}"
        using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]]
        by metis
      hence "c. ?P c" using not_finite_existsD by blast
      thus ?case using someI_ex[of ?P] by auto
    next
      case (Fun f T)
      have f: "0 < arity f" "length T = arity f" "public f" "T  []"
        using Fun.prems fun_type_inv unfolding wftrm_def by auto
      obtain t' where t': "t'  set T" by (meson all_not_in_conv f(4) set_empty)
      have "t. t  set T  ?P t"
        using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm
        by metis
      hence "t. t  set T  c. Fun c []  fresh_pgwt S t  c  S"
        using Fun.prems Fun.IH by auto
      then obtain c where c: "Fun c []  fresh_pgwt S t'" "c  S" using t' by metis
      thus ?case using t' by auto
    qed
  } thus ?thesis using that assms Γ_wf'[OF assms(2)] Γ_wf(1) by blast
qed

private lemma fresh_pgwt_subterm_fresh:
  assumes "finite S" "wftrm t" "wftrm s" "funs_term s  S"
  shows "s  subterms (fresh_pgwt S (Γ t))"
proof -
  let ?P = "λτ::('fun,'atom) term_type. wftrm τ  (f T. TComp f T  τ  0 < arity f)"
  { fix τ assume "?P τ" hence "s  subterms (fresh_pgwt S τ)"
    proof (induction τ)
      case (Var a)
      let ?P = "λc. c  S  Γ (Fun c []) = Var a  public c"
      let ?Q = "λc. Γ (Fun c []) = Var a  public c"
      have " {c. ?Q c} - S = {c. ?P c}" by auto
      hence "infinite {c. ?P c}"
        using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]]
        by metis
      hence "c. ?P c" using not_finite_existsD by blast
      thus ?case using someI_ex[of ?P] assms(4) by auto
    next
      case (Fun f T)
      have f: "0 < arity f" "length T = arity f" "public f"
        using Fun.prems fun_type_inv unfolding wftrm_def by auto
      have "t. t  set T  ?P t"
        using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm
        by metis
      hence "t. t  set T  s  subterms (fresh_pgwt S t)" using Fun.prems Fun.IH by auto
      moreover have "s  fresh_pgwt S (Fun f T)"
      proof -
        obtain c where c: "Fun c []  fresh_pgwt S (Fun f T)" "c  S"
          using fresh_pgwt_has_fresh_const[OF assms(1)] type_wfttype_inhabited Fun.prems
          by metis
        hence "¬Fun c []  s" using assms(4) subtermeq_imp_funs_term_subset by force
        thus ?thesis using c(1) by auto
      qed
      ultimately show ?case by auto
    qed
  } thus ?thesis using assms(1) Γ_wf'[OF assms(2)] Γ_wf(1) by auto
qed

private lemma wt_fresh_pgwt_term_exists:
  assumes "finite T" "wftrm s" "wftrms T"
  obtains t where "Γ t = Γ s" "{} c t" "s  T. u  subterms s. u  subterms t"
proof -
  have finite_S: "finite ((funs_term ` T))" using assms(1) by auto

  have 1: "Γ (fresh_pgwt ((funs_term ` T)) (Γ s)) = Γ s"
    using fresh_pgwt_same_type[OF finite_S assms(2)] by auto

  have 2: "{} c fresh_pgwt ((funs_term ` T)) (Γ s)"
    using fresh_pgwt_empty_synth[OF finite_S assms(2)] by auto

  have 3: "v  T. u  subterms v. u  subterms (fresh_pgwt ((funs_term ` T)) (Γ s))"
    using fresh_pgwt_subterm_fresh[OF finite_S assms(2)] assms(3)
          wf_trm_subtermeq subtermeq_imp_funs_term_subset
    by force

  show ?thesis by (rule that[OF 1 2 3])
qed

lemma wt_bij_finite_subst_exists:
  assumes "finite (S::'var set)" "finite (T::('fun,'var) terms)" "wftrms T"
  shows "σ::('fun,'var) subst.
              subst_domain σ = S
             bij_betw σ (subst_domain σ) (subst_range σ)
             subtermsset (subst_range σ)  {t. {} c t} - T
             (s  subst_range σ. u  subst_range σ. (v. v  s  v  u)  s = u)
             wtsubst σ
             wftrms (subst_range σ)"
using assms
proof (induction rule: finite_induct)
  case empty
  have "subst_domain Var = {}"
       "bij_betw Var (subst_domain Var) (subst_range Var)"
       "subtermsset (subst_range Var)  {t. {} c t} - T"
       "s  subst_range Var. u  subst_range Var. (v. v  s  v  u)  s = u"
       "wtsubst Var"
       "wftrms (subst_range Var)"
    unfolding bij_betw_def
    by auto
  thus ?case by (force simp add: subst_domain_def)
next
  case (insert x S)
  then obtain σ where σ:
      "subst_domain σ = S" "bij_betw σ (subst_domain σ) (subst_range σ)"
      "subtermsset (subst_range σ)  {t. {} c t} - T"
      "s  subst_range σ. u  subst_range σ. (v. v  s  v  u)  s = u"
      "wtsubst σ" "wftrms (subst_range σ)"
    by (auto simp del: subst_range.simps)

  have *: "finite (T  subst_range σ)"
    using insert.prems(1) insert.hyps(1) σ(1) by simp
  have **: "wftrm (Var x)" by simp
  have ***: "wftrms (T  subst_range σ)" using assms(3) σ(6) by blast
  obtain t where t:
      "Γ t = Γ (Var x)" "{} c t"
      "s  T  subst_range σ. u  subterms s. u  subterms t"
    using wt_fresh_pgwt_term_exists[OF * ** ***] by auto

  obtain θ where θ: "θ  λy. if x = y then t else σ y" by simp

  have t_ground: "fv t = {}" using t(2) pgwt_ground[of t] pgwt_is_empty_synth[of t] by auto
  hence x_dom: "x  subst_domain σ" "x  subst_domain θ" using insert.hyps(2) σ(1) θ by auto
  moreover have "subst_range σ  subtermsset (subst_range σ)" by auto
  hence ground_imgs: "ground (subst_range σ)"
    using σ(3) pgwt_ground pgwt_is_empty_synth
    by force
  ultimately have x_img: "σ x  subst_range σ"
    using ground_subst_dom_iff_img
    by (auto simp add: subst_domain_def)

  have "ground (insert t (subst_range σ))"
    using ground_imgs x_dom t_ground
    by auto
  have θ_dom: "subst_domain θ = insert x (subst_domain σ)"
    using θ t_ground by (auto simp add: subst_domain_def)
  have θ_img: "subst_range θ = insert t (subst_range σ)"
  proof
    show "subst_range θ  insert t (subst_range σ)"
    proof
      fix t' assume "t'  subst_range θ"
      then obtain y where "y  subst_domain θ" "t' = θ y" by auto
      thus "t'  insert t (subst_range σ)" using θ by (auto simp add: subst_domain_def)
    qed
    show "insert t (subst_range σ)  subst_range θ"
    proof
      fix t' assume t': "t'  insert t (subst_range σ)"
      hence "fv t' = {}" using ground_imgs x_img t_ground by auto
      hence "t'  Var x" by auto
      show "t'  subst_range θ"
      proof (cases "t' = t")
        case False
        hence "t'  subst_range σ" using t' by auto
        then obtain y where "σ y  subst_range σ" "t' = σ y" by auto
        hence "y  subst_domain σ" "t'  Var y"
          using ground_subst_dom_iff_img[OF ground_imgs(1)]
          by (auto simp add: subst_domain_def simp del: subst_range.simps)
        hence "x  y" using x_dom by auto
        hence "θ y = σ y" unfolding θ by auto
        thus ?thesis using t'  Var y t' = σ y subst_imgI[of θ y] by auto
      qed (metis subst_imgI θ t'  Var x)
    qed
  qed
  hence θ_ground_img: "ground (subst_range θ)"
    using ground_imgs t_ground
    by auto

  have "subst_domain θ = insert x S" using θ_dom σ(1) by auto
  moreover have "bij_betw θ (subst_domain θ) (subst_range θ)"
  proof (intro bij_betwI')
    fix y z assume *: "y  subst_domain θ" "z  subst_domain θ"
    hence "fv (θ y) = {}" "fv (θ z) = {}" using θ_ground_img by auto
    { assume "θ y = θ z" hence "y = z"
      proof (cases "θ y  subst_range σ  θ z  subst_range σ")
        case True
        hence **: "y  subst_domain σ" "z  subst_domain σ"
          using θ θ_dom True * t(3) by (metis Un_iff term.order_refl insertE)+
        hence "y  x" "z  x" using x_dom by auto
        hence "θ y = σ y" "θ z = σ z" using θ by auto
        thus ?thesis using θ y = θ z σ(2) ** unfolding bij_betw_def inj_on_def by auto
      qed (metis θ * θ y = θ z θ_dom ground_imgs(1) ground_subst_dom_iff_img insertE)
    }
    thus "(θ y = θ z) = (y = z)" by auto
  next
    fix y assume "y  subst_domain θ" thus "θ y  subst_range θ" by auto
  next
    fix t assume "t  subst_range θ" thus "z  subst_domain θ. t = θ z" by auto
  qed
  moreover have "subtermsset (subst_range θ)  {t. {} c t}  - T"
  proof -
    { fix s assume "s  t"
      hence "s  {t. {} c t}  - T"
        using t(2,3)
        by (metis Diff_eq_empty_iff Diff_iff Un_upper1 term.order_refl
                  deduct_synth_subterm mem_Collect_eq)
    } thus ?thesis using σ(3) θ θ_img by auto
  qed
  moreover have "wtsubst θ" using θ t(1) σ(5) unfolding wtsubst_def by auto
  moreover have "wftrms (subst_range θ)"
    using θ σ(6) t(2) pgwt_is_empty_synth pgwt_wellformed
          wf_trm_subst_range_iff[of σ] wf_trm_subst_range_iff[of θ]
    by metis
  moreover have "ssubst_range θ. usubst_range θ. (v. v  s  v  u)  s = u"
    using σ(4) θ_img t(3) by (auto simp del: subst_range.simps)
  ultimately show ?case by blast
qed

private lemma wt_bij_finite_tatom_subst_exists_single:
  assumes "finite (S::'var set)" "finite (T::('fun,'var) terms)"
  and "x. x  S  Γ (Var x) = TAtom a"
  shows "σ::('fun,'var) subst. subst_domain σ = S
                       bij_betw σ (subst_domain σ) (subst_range σ)
                       subst_range σ  ((λc. Fun c []) `  {c. Γ (Fun c []) = TAtom a 
                                                            public c  arity c = 0}) - T
                       wtsubst σ
                       wftrms (subst_range σ)"
proof -
  let ?U = "{c. Γ (Fun c []) = TAtom a  public c  arity c = 0}"

  obtain σ where σ:
      "subst_domain σ = S" "bij_betw σ (subst_domain σ) (subst_range σ)"
      "subst_range σ  ((λc. Fun c []) ` ?U) - T"
    using bij_finite_const_subst_exists'[OF assms(1,2) infinite_typed_consts'[of a]]
    by auto

  { fix x assume "x  subst_domain σ" hence "Γ (Var x) = Γ (σ x)" by auto }
  moreover
  { fix x assume "x  subst_domain σ"
    hence "c  ?U. σ x = Fun c []  arity c = 0" using σ by auto
    hence "Γ (σ x) = TAtom a" "wftrm (σ x)" using assms(3) const_type wf_trmI[of "[]"] by auto
    hence "Γ (Var x) = Γ (σ x)" "wftrm (σ x)" using assms(3) σ(1) by force+
  }
  ultimately have "wtsubst σ" "wftrms (subst_range σ)"
    using wf_trm_subst_range_iff[of σ]
    unfolding wtsubst_def
    by force+
  thus ?thesis using σ by auto
qed

lemma wt_bij_finite_tatom_subst_exists:
  assumes "finite (S::'var set)" "finite (T::('fun,'var) terms)"
  and "x. x  S  a. Γ (Var x) = TAtom a"
  shows "σ::('fun,'var) subst. subst_domain σ = S
                       bij_betw σ (subst_domain σ) (subst_range σ)
                       subst_range σ  ((λc. Fun c []) `  𝒞pub) - T
                       wtsubst σ
                       wftrms (subst_range σ)"
using assms
proof (induction rule: finite_induct)
  case empty
  have "subst_domain Var = {}"
       "bij_betw Var (subst_domain Var) (subst_range Var)"
       "subst_range Var  ((λc. Fun c []) `  𝒞pub) - T"
       "wtsubst Var"
       "wftrms (subst_range Var)"
    unfolding bij_betw_def
    by auto
  thus ?case by (auto simp add: subst_domain_def)
next
  case (insert x S)
  then obtain a where a: "Γ (Var x) = TAtom a" by fastforce

  from insert obtain σ where σ:
      "subst_domain σ = S" "bij_betw σ (subst_domain σ) (subst_range σ)"
      "subst_range σ  ((λc. Fun c []) `  𝒞pub) - T" "wtsubst σ"
      "wftrms (subst_range σ)"
    by auto

  let ?S' = "{y  S. Γ (Var y) = TAtom a}"
  let ?T' = "T  subst_range σ"

  have *: "finite (insert x ?S')" using insert by simp
  have **: "finite ?T'" using insert.prems(1) insert.hyps(1) σ(1) by simp
  have ***: "y. y  insert x ?S'  Γ (Var y) = TAtom a" using a by auto

  obtain δ where δ:
      "subst_domain δ = insert x ?S'" "bij_betw δ (subst_domain δ) (subst_range δ)"
      "subst_range δ  ((λc. Fun c []) `  𝒞pub) - ?T'" "wtsubst δ" "wftrms (subst_range δ)"
    using wt_bij_finite_tatom_subst_exists_single[OF * ** ***] const_type_inv[of _ "[]" a]
    by blast

  obtain θ where θ: "θ  λy. if x = y then δ y else σ y" by simp

  have x_dom: "x  subst_domain σ" "x  subst_domain δ" "x  subst_domain θ"
    using insert.hyps(2) σ(1) δ(1) θ by (auto simp add: subst_domain_def)
  moreover have ground_imgs: "ground (subst_range σ)" "ground (subst_range δ)"
    using pgwt_ground σ(3) δ(3) by auto
  ultimately have x_img: "σ x  subst_range σ" "δ x  subst_range δ"
    using ground_subst_dom_iff_img by (auto simp add: subst_domain_def)

  have "ground (insert (δ x) (subst_range σ))" using ground_imgs x_dom by auto
  have θ_dom: "subst_domain θ = insert x (subst_domain σ)"
    using δ(1) θ by (auto simp add: subst_domain_def)
  have θ_img: "subst_range θ = insert (δ x) (subst_range σ)"
  proof
    show "subst_range θ  insert (δ x) (subst_range σ)"
    proof
      fix t assume "t  subst_range θ"
      then obtain y where "y  subst_domain θ" "t = θ y" by auto
      thus "t  insert (δ x) (subst_range σ)" using θ by (auto simp add: subst_domain_def)
    qed
    show "insert (δ x) (subst_range σ)  subst_range θ"
    proof
      fix t assume t: "t  insert (δ x) (subst_range σ)"
      hence "fv t = {}" using ground_imgs x_img(2) by auto
      hence "t  Var x" by auto
      show "t  subst_range θ"
      proof (cases "t = δ x")
        case True thus ?thesis using subst_imgI θ t  Var x by metis
      next
        case False
        hence "t  subst_range σ" using t by auto
        then obtain y where "σ y  subst_range σ" "t = σ y" by auto
        hence "y  subst_domain σ" "t  Var y"
          using ground_subst_dom_iff_img[OF ground_imgs(1)]
          by (auto simp add: subst_domain_def simp del: subst_range.simps)
        hence "x  y" using x_dom by auto
        hence "θ y = σ y" unfolding θ by auto
        thus ?thesis using t  Var y t = σ y subst_imgI[of θ y] by auto
      qed
    qed
  qed
  hence θ_ground_img: "ground (subst_range θ)" using ground_imgs x_img by auto

  have "subst_domain θ = insert x S" using θ_dom σ(1) by auto
  moreover have "bij_betw θ (subst_domain θ) (subst_range θ)"
  proof (intro bij_betwI')
    fix y z assume *: "y  subst_domain θ" "z  subst_domain θ"
    hence "fv (θ y) = {}" "fv (θ z) = {}" using θ_ground_img by auto
    { assume "θ y = θ z" hence "y = z"
      proof (cases "θ y  subst_range σ  θ z  subst_range σ")
        case True
        hence **: "y  subst_domain σ" "z  subst_domain σ"
          using θ θ_dom x_img(2) δ(3) True
          by (metis (no_types) *(1) DiffE Un_upper2 insertE subsetCE,
              metis (no_types) *(2) DiffE Un_upper2 insertE subsetCE)
        hence "y  x" "z  x" using x_dom by auto
        hence "θ y = σ y" "θ z = σ z" using θ by auto
        thus ?thesis using θ y = θ z σ(2) ** unfolding bij_betw_def inj_on_def by auto
      qed (metis θ * θ y = θ z θ_dom ground_imgs(1) ground_subst_dom_iff_img insertE)
    }
    thus "(θ y = θ z) = (y = z)" by auto
  next
    fix y assume "y  subst_domain θ" thus "θ y  subst_range θ" by auto
  next
    fix t assume "t  subst_range θ" thus "z  subst_domain θ. t = θ z" by auto
  qed
  moreover have "subst_range θ  (λc. Fun c []) ` 𝒞pub - T"
    using σ(3) δ(3) θ by (auto simp add: subst_domain_def)
  moreover have "wtsubst θ" using σ(4) δ(4) θ unfolding wtsubst_def by auto
  moreover have "wftrms (subst_range θ)"
    using θ σ(5) δ(5) wf_trm_subst_range_iff[of δ]
          wf_trm_subst_range_iff[of σ] wf_trm_subst_range_iff[of θ]
    by presburger
  ultimately show ?case by blast
qed

theorem wt_sat_if_simple:
  assumes "simple S" "wfconstr S θ" "wtsubst θ" "wftrms (subst_range θ)" "wftrms (trmsst S)"
  and ℐ': "X F. Inequality X F  set S  ineq_model ℐ' X F"
         "ground (subst_range ℐ')"
         "subst_domain ℐ' = {x  varsst S. X F. Inequality X F  set S  x  fvpairs F - set X}"
  and tfr_stp_all: "list_all tfrstp S"
  shows ". interpretationsubst   ( c S, θ)  wtsubst   wftrms (subst_range )"
proof -
  from ‹wfconstr S θ have "wfst {} S" "subst_idem θ" and S_θ_disj: "v  varsst S. θ v = Var v"
    using subst_idemI[of θ] unfolding wfconstr_def wfsubst_def by force+

  obtain ::"('fun,'var) subst"
    where: "interpretationsubst " "wtsubst " "subst_range   public_ground_wf_terms"
    using wt_interpretation_exists by blast
  hence ℐ_deduct: "x M. M c  x" and ℐ_wf_trm: "wftrms (subst_range )"
    using pgwt_deducible pgwt_wellformed by fastforce+

  let ?P = "λδ X. subst_domain δ = set X  ground (subst_range δ)"
  let ?Sineqsvars = "{x  varsst S. X F. Inequality X F  set S  x  fvpairs F  x  set X}"
  let ?Strms = "subtermsset (trmsst S)"

  have finite_vars: "finite ?Sineqsvars" "finite ?Strms" "wftrms ?Strms"
    using wf_trm_subtermeq assms(5) by fastforce+

  define Q1 where "Q1 = (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
    x  fvpairs F - set X. a. Γ (Var x) = TAtom a)"

  define Q2 where "Q2 = (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
    f T. Fun f T  subtermsset (trmspairs F)  T = []  (s  set T. s  Var ` set X))"

  define Q1' where "Q1' = (λ(t::('fun,'var) term) (t'::('fun,'var) term) X.
    x  (fv t  fv t') - set X. a. Γ (Var x) = TAtom a)"

  define Q2' where "Q2' = (λ(t::('fun,'var) term) (t'::('fun,'var) term) X.
    f T. Fun f T  subterms t  subterms t'  T = []  (s  set T. s  Var ` set X))"

  have ex_P: "X. δ. ?P δ X" using interpretation_subst_exists' by blast

  have tfr_ineq: "X F. Inequality X F  set S  Q1 F X  Q2 F X"
    using tfr_stp_all Q1_def Q2_def tfrstp_list_all_alt_def[of S] by blast

  have S_fv_bvars_disj: "fvst S  bvarsst S = {}" using ‹wfconstr S θ unfolding wfconstr_def by metis
  hence ineqs_vars_not_bound: "X F x. Inequality X F  set S  x  ?Sineqsvars  x  set X"
    using strand_fv_bvars_disjoint_unfold by blast

  have θ_vars_S_bvars_disj: "(subst_domain θ  range_vars θ)  set X = {}"
    when "Inequality X F  set S" for F X
    using wf_constr_bvars_disj[OF ‹wfconstr S θ]
          strand_fv_bvars_disjointD(1)[OF S_fv_bvars_disj that]
    by blast

  obtain σ::"('fun,'var) subst"
    where σ_fv_dom: "subst_domain σ = ?Sineqsvars"
    and σ_subterm_inj: "subterm_inj_on σ (subst_domain σ)"
    and σ_fresh_pub_img: "subtermsset (subst_range σ)  {t. {} c t} - ?Strms"
    and σ_wt: "wtsubst σ"
    and σ_wf_trm: "wftrms (subst_range σ)"
    using wt_bij_finite_subst_exists[OF finite_vars]
          subst_inj_on_is_bij_betw subterm_inj_on_alt_def'
    by moura

  have σ_bij_dom_img: "bij_betw σ (subst_domain σ) (subst_range σ)"
    by (metis σ_subterm_inj subst_inj_on_is_bij_betw subterm_inj_on_alt_def)

  have "finite (subst_domain σ)" by(metis σ_fv_dom finite_vars(1))
  hence σ_finite_img: "finite (subst_range σ)" using σ_bij_dom_img bij_betw_finite by blast

  have σ_img_subterms: "s  subst_range σ. u  subst_range σ. (v. v  s  v  u)  s = u"
    by (metis σ_subterm_inj subterm_inj_on_alt_def')

  have "subst_range σ  subtermsset (subst_range σ)" by auto
  hence "subst_range σ  public_ground_wf_terms - ?Strms"
      and σ_pgwt_img:
        "subst_range σ  public_ground_wf_terms"
        "subtermsset (subst_range σ)  public_ground_wf_terms"
    using σ_fresh_pub_img pgwt_is_empty_synth by blast+

  have σ_img_ground: "ground (subst_range σ)"
    using σ_pgwt_img pgwt_ground by auto
  hence σ_inj: "inj σ"
    using σ_bij_dom_img subst_inj_is_bij_betw_dom_img_if_ground_img by auto

  have σ_ineqs_fv_dom: "X F. Inequality X F  set S  fvpairs F - set X  subst_domain σ"
    using σ_fv_dom by fastforce

  have σ_dom_bvars_disj: "X F. Inequality X F  set S  subst_domain σ  set X = {}"
    using ineqs_vars_not_bound σ_fv_dom by fastforce

  have ℐ'1: "X F δ. Inequality X F  set S  fvpairs F - set X  subst_domain ℐ'"
    using ℐ'(3) ineqs_vars_not_bound by fastforce

  have ℐ'2: "X F. Inequality X F  set S  subst_domain ℐ'  set X = {}"
    using ℐ'(3) ineqs_vars_not_bound by blast

  have doms_eq: "subst_domain ℐ' = subst_domain σ" using ℐ'(3) σ_fv_dom by simp

  have σ_ineqs_neq: "ineq_model σ X F" when "Inequality X F  set S" for X F
  proof -
    obtain a::"'fun" where a: "a  (funs_term ` subtermsset (subst_range σ))"
      using exists_fun_notin_funs_terms[OF subterms_union_finite[OF σ_finite_img]]
      by moura
    hence a': "T. Fun a T  subtermsset (subst_range σ)"
              "S. Fun a []  set (Fun a []#S)" "Fun a []  Var ` set X"
      by (meson a UN_I term.set_intros(1), auto)

    define t where "t  Fun a (Fun a []#map fst F)"
    define t' where "t'  Fun a (Fun a []#map snd F)"

    note F_in = that

    have t_fv: "fv t  fv t'  fvpairs F"
      unfolding t_def t'_def by force

    have t_subterms: "subterms t  subterms t'  subtermsset (trmspairs F)  {t, t', Fun a []}"
      unfolding t_def t'_def by force

    have "t  δ  σ  t'  δ  σ" when "?P δ X" for δ
    proof -
      have tfr_assms: "Q1 F X  Q2 F X" using tfr_ineq F_in by metis

      have "Q1 F X  x  fvpairs F - set X. c. σ x = Fun c []"
      proof
        fix x assume "Q1 F X" and x: "x  fvpairs F - set X"
        then obtain a where "Γ (Var x) = TAtom a" unfolding Q1_def by moura
        hence a: "Γ (σ x) = TAtom a" using σ_wt unfolding wtsubst_def by simp

        have "x  subst_domain σ" using σ_ineqs_fv_dom x F_in by auto
        then obtain f T where fT: "σ x = Fun f T" by (meson σ_img_ground ground_img_obtain_fun)
        hence "T = []" using σ_wf_trm a TAtom_term_cases by fastforce
        thus "c. σ x = Fun c []" using fT by metis
      qed
      hence 1: "Q1 F X  x  (fv t  fv t') - set X. c. σ x = Fun c []"
        using t_fv by auto

      have 2: "¬Q1 F X  Q2 F X" by (metis tfr_assms)

      have 3: "subst_domain σ  set X = {}" using σ_dom_bvars_disj F_in by auto

      have 4: "subtermsset (subst_range σ)  (subterms t  subterms t') = {}"
      proof -
        define M1 where "M1  {t, t', Fun a []}"
        define M2 where "M2  ?Strms"

        have "subtermsset (trmspairs F)  M2"
          using F_in unfolding M2_def by force
        moreover have "subterms t  subterms t'  subtermsset (trmspairs F)  M1"
          using t_subterms unfolding M1_def by blast
        ultimately have *: "subterms t  subterms t'  M2  M1"
          by auto

        have "subtermsset (subst_range σ)  M1 = {}"
             "subtermsset (subst_range σ)  M2 = {}"
          using a' σ_fresh_pub_img
          unfolding t_def t'_def M1_def M2_def
          by blast+
        thus ?thesis using * by blast
      qed

      have 5: "(fv t  fv t') - subst_domain σ  set X"
        using σ_ineqs_fv_dom[OF F_in] t_fv
        by auto

      have 6: "δ. ?P δ X  t  δ  ℐ'  t'  δ  ℐ'"
        by (metis t_def t'_def ℐ'(1) F_in ineq_model_singleE ineq_model_single_iff)

      have 7: "fv t  fv t' - set X  subst_domain ℐ'" using ℐ'1 F_in t_fv by force

      have 8: "subst_domain ℐ'  set X = {}" using ℐ'2 F_in by auto

      have 9: "Q1' t t' X" when "Q1 F X"
        using that t_fv
        unfolding Q1_def Q1'_def t_def t'_def
        by blast

      have 10: "Q2' t t' X" when "Q2 F X" unfolding Q2'_def
      proof (intro allI impI)
        fix f T assume "Fun f T  subterms t  subterms t'"
        moreover {
          assume "Fun f T  subtermsset (trmspairs F)"
          hence "T = []  (sset T. s  Var ` set X)" by (metis Q2_def that)
        } moreover {
          assume "Fun f T = t" hence "T = []  (sset T. s  Var ` set X)"
            unfolding t_def using a'(2,3) by simp
        } moreover {
          assume "Fun f T = t'" hence "T = []  (sset T. s  Var ` set X)"
            unfolding t'_def using a'(2,3) by simp
        } moreover {
          assume "Fun f T = Fun a []" hence "T = []  (sset T. s  Var ` set X)" by simp
        } ultimately show "T = []  (sset T. s  Var ` set X)" using t_subterms by blast
      qed

      note 11 = σ_subterm_inj σ_img_ground 3 4 5

      note 12 = 6 7 8 ℐ'(2) doms_eq

      show "t  δ  σ  t'  δ  σ"
        using 1 2 9 10 that sat_ineq_subterm_inj_subst[OF 11 _ 12]
        unfolding Q1'_def Q2'_def by metis
    qed
    thus ?thesis by (metis t_def t'_def ineq_model_singleI ineq_model_single_iff)
  qed

  have σ_ineqs_fv_dom': "fvpairs (F pairs δ)  subst_domain σ"
    when "Inequality X F  set S" and "?P δ X" for F δ X
    using σ_ineqs_fv_dom[OF that(1)]
  proof (induction F)
    case (Cons g G)
    obtain t t' where g: "g = (t,t')" by (metis surj_pair)
    hence "fvpairs (g#G pairs δ)  = fv (t  δ)  fv (t'  δ)  fvpairs (G pairs δ)"
          "fvpairs (g#G) = fv t  fv t'  fvpairs G"
      by (simp_all add: subst_apply_pairs_def)
    moreover have "fv (t  δ) = fv t - subst_domain δ" "fv (t'  δ) = fv t' - subst_domain δ"
      using g that(2) by (simp_all add: subst_fv_unfold_ground_img range_vars_alt_def)
    moreover have "fvpairs (G pairs δ)  subst_domain σ" using Cons by auto
    ultimately show ?case using Cons.prems that(2) by auto
  qed (simp add: subst_apply_pairs_def)

  have σ_ineqs_ground: "fvpairs ((F pairs δ) pairs σ) = {}"
    when "Inequality X F  set S" and "?P δ X" for F δ X
    using σ_ineqs_fv_dom'[OF that]
  proof (induction F)
    case (Cons g G)
    obtain t t' where g: "g = (t,t')" by (metis surj_pair)
    hence "fv (t  δ)  subst_domain σ" "fv (t'  δ)  subst_domain σ"
      using Cons.prems by (auto simp add: subst_apply_pairs_def)
    hence "fv (t  δ  σ) = {}" "fv (t'  δ  σ) = {}"
      using subst_fv_dom_ground_if_ground_img[OF _ σ_img_ground] by metis+
    thus ?case using g Cons by (auto simp add: subst_apply_pairs_def)
  qed (simp add: subst_apply_pairs_def)

  from σ_pgwt_img σ_ineqs_neq have σ_deduct: "M c σ x" when "x  subst_domain σ" for x M
    using that pgwt_deducible by fastforce

  { fix M::"('fun,'var) terms"
    have "M; Sc (θ s σ s )"
      using ‹wfst {} S ‹simple S S_θ_disj σ_ineqs_neq σ_ineqs_fv_dom' θ_vars_S_bvars_disj
    proof (induction S arbitrary: M rule: wfst_simple_induct)
      case (ConsSnd v S)
      hence S_sat: "M; Sc (θ s σ s )" and "θ v = Var v" by auto
      hence "M. M c Var v  (θ s σ s )"
        using ℐ_deduct σ_deduct
        by (metis ideduct_synth_subst_apply subst_apply_term.simps(1)
                  subst_subst_compose trm_subst_ident')
      thus ?case using strand_sem_append(1)[OF S_sat] by (metis strand_sem_c.simps(1,2))
    next
      case (ConsIneq X F S)
      have dom_disj: "subst_domain θ  fvpairs F = {}"
        using ConsIneq.prems(1) subst_dom_vars_in_subst
        by force
      hence *: "F pairs θ = F" by blast

      have **: "ineq_model σ X F" by (meson ConsIneq.prems(2) in_set_conv_decomp)

      have "x. x  varsst S  x  varsst (S@[Inequality X F])"
           "x. x  set S  x  set (S@[Inequality X F])" by auto
      hence IH: "M; Sc (θ s σ s )" by (metis ConsIneq.IH ConsIneq.prems(1,2,3,4))

      have "ineq_model (σ s ) X F"
      proof -
        have "fvpairs (F pairs δ)  subst_domain σ" when "?P δ X" for δ
          using ConsIneq.prems(3)[OF _ that] by simp
        hence "fvpairs F - set X  subst_domain σ"
          using fvpairs_subst_subset ex_P
          by (metis Diff_subset_conv Un_commute)
        thus ?thesis by (metis ineq_model_ground_subst[OF _ σ_img_ground **])
      qed
      hence "ineq_model (θ s σ s ) X F"
        using * ineq_model_subst' subst_compose_assoc ConsIneq.prems(4)
        by (metis UnCI list.set_intros(1) set_append)
      thus ?case using IH by (auto simp add: ineq_model_def)
    qed auto
  }
  moreover have "wtsubst (θ s σ s )" "wftrms (subst_range (θ s σ s ))"
    by (metis wt_subst_compose ‹wtsubst θ ‹wtsubst σ ‹wtsubst ,
        metis assms(4) ℐ_wf_trm σ_wf_trm wf_trm_subst subst_img_comp_subset')
  ultimately show ?thesis
    using interpretation_comp(1)[OF ‹interpretationsubst , of "θ s σ"]
          subst_idem_support[OF ‹subst_idem θ, of "σ s "] subst_compose_assoc
    unfolding constr_sem_c_def by metis
qed
end


subsubsection ‹Theorem: Type-flaw resistant constraints are well-typed satisfiable (composition-only)›
text ‹
  There exists well-typed models of satisfiable type-flaw resistant constraints in the
  semantics where the intruder is limited to composition only (i.e., he cannot perform
  decomposition/analysis of deducible messages).
›
theorem wt_attack_if_tfr_attack:
  assumes "interpretationsubst "
    and " c S, θ"
    and "wfconstr S θ"
    and "wtsubst θ"
    and "tfrst S"
    and "wftrms (trmsst S)"
    and "wftrms (subst_range θ)"
  obtains τ where "interpretationsubst τ"
    and "τ c S, θ"
    and "wtsubst τ"
    and "wftrms (subst_range τ)"
proof -
  have tfr: "tfrset (trmsst S)" "wftrms (trmsst S)" "list_all tfrstp S"
    using assms(5,6) unfolding tfrst_def by metis+
  obtain S' θ' where *: "simple S'" "(S,θ) * (S',θ')" "{}; S'c "
    using LI_completeness[OF assms(3,2)] unfolding constr_sem_c_def
    by (meson term.order_refl)
  have **: "wfconstr S' θ'" "wtsubst θ'" "list_all tfrstp S'" "wftrms (trmsst S')" "wftrms (subst_range θ')"
    using LI_preserves_welltypedness[OF *(2) assms(3,4,7) tfr]
          LI_preserves_wellformedness[OF *(2) assms(3)]
          LI_preserves_tfr[OF *(2) assms(3,4,7) tfr]
    by metis+

  define A where "A  {x  varsst S'. X F. Inequality X F  set S'  x  fvpairs F  x  set X}"
  define B where "B  UNIV - A"

  let ?ℐ = "rm_vars B "

  have grℐ: "ground (subst_range )" "ground (subst_range ?ℐ)"
    using assms(1) rm_vars_img_subset[of B ] by (auto simp add: subst_domain_def)

  { fix X F
    assume "Inequality X F  set S'"
    hence *: "ineq_model  X F"
      using strand_sem_c_imp_ineq_model[OF *(3)]
      by (auto simp del: subst_range.simps)
    hence "ineq_model ?ℐ X F"
    proof -
      { fix δ
        assume 1: "subst_domain δ = set X" "ground (subst_range δ)"
            and 2: "list_ex (λf. fst f  δ s   snd f  δ s ) F"
        have "list_ex (λf. fst f  δ s rm_vars B   snd f  δ s rm_vars B ) F" using 2
        proof (induction F)
          case (Cons g G)
          obtain t t' where g: "g = (t,t')" by (metis surj_pair)
          thus ?case
            using Cons Unifier_ground_rm_vars[OF grℐ(1), of "t  δ" B "t'  δ"]
            by auto
        qed simp
      } thus ?thesis using * unfolding ineq_model_def by simp
    qed
  } moreover have "subst_domain  = UNIV" using assms(1) by metis
  hence "subst_domain ?ℐ = A" using rm_vars_dom[of B ] B_def by blast
  ultimately obtain τ where
      "interpretationsubst τ" "τ c S', θ'" "wtsubst τ" "wftrms (subst_range τ)"
    using wt_sat_if_simple[OF *(1) **(1,2,5,4) _ grℐ(2) _ **(3)] A_def
    by (auto simp del: subst_range.simps)
  thus ?thesis using that LI_soundness[OF assms(3) *(2)] by metis
qed

text ‹
  Contra-positive version: if a type-flaw resistant constraint does not have a well-typed model
  then it is unsatisfiable
›
corollary secure_if_wt_secure:
  assumes "¬(τ. interpretationsubst τ  (τ c S, θ)  wtsubst τ)"
  and     "wfconstr S θ" "wtsubst θ" "tfrst S"
  and     "wftrms (trmsst S)" "wftrms (subst_range θ)"
  shows "¬(. interpretationsubst   ( c S, θ))"
using wt_attack_if_tfr_attack[OF _ _ assms(2,3,4,5,6)] assms(1) by metis

end


subsection ‹Lifting the Composition-Only Typing Result to the Full Intruder Model›
context typed_model
begin

subsubsection ‹Analysis Invariance›
definition (in typed_model) Ana_invar_subst where
  "Ana_invar_subst  
    (f T K M δ. Fun f T  (subtermsset ) 
                 Ana (Fun f T) = (K, M)  Ana (Fun f T  δ) = (K list δ, M list δ))"

lemma (in typed_model) Ana_invar_subst_subset:
  assumes "Ana_invar_subst M" "N  M"
  shows "Ana_invar_subst N"
using assms unfolding Ana_invar_subst_def by blast

lemma (in typed_model) Ana_invar_substD:
  assumes "Ana_invar_subst "
  and "Fun f T  subtermsset " "Ana (Fun f T) = (K, M)"
  shows "Ana (Fun f T  ) = (K list , M list )"
using assms Ana_invar_subst_def by blast

end


subsubsection ‹Preliminary Definitions›
text ‹Strands extended with "decomposition steps"›
datatype (funsestp: 'a, varsestp: 'b) extstrand_step =
  Step   "('a,'b) strand_step"
| Decomp "('a,'b) term"

context typed_model
begin

context
begin
private fun trmsestp where
  "trmsestp (Step x) = trmsstp x"
| "trmsestp (Decomp t) = {t}"

private abbreviation trmsest where "trmsest S  (trmsestp ` set S)"

private type_synonym ('a,'b) extstrand = "('a,'b) extstrand_step list"
private type_synonym ('a,'b) extstrands = "('a,'b) extstrand set"

private definition decomp::"('fun,'var) term  ('fun,'var) strand" where
  "decomp t  (case (Ana t) of (K,T)  send⟨tst#map Send K@map Receive T)"

private fun to_st where
  "to_st [] = []"
| "to_st (Step x#S) = x#(to_st S)"
| "to_st (Decomp t#S) = (decomp t)@(to_st S)"

private fun to_est where
  "to_est [] = []"
| "to_est (x#S) = Step x#to_est S"

private abbreviation "ikest A  ikst (to_st A)"
private abbreviation "wfest V A  wfst V (to_st A)"
private abbreviation "assignment_rhsest A  assignment_rhsst (to_st A)"
private abbreviation "varsest A  varsst (to_st A)"
private abbreviation "wfrestrictedvarsest A  wfrestrictedvarsst (to_st A)"
private abbreviation "bvarsest A  bvarsst (to_st A)"
private abbreviation "fvest A  fvst (to_st A)"
private abbreviation "funsest A  funsst (to_st A)"

private definition wfsts'::"('fun,'var) strands  ('fun,'var) extstrand  bool" where
  "wfsts' 𝒮 𝒜  (S  𝒮. wfst (wfrestrictedvarsest 𝒜) (dualst S)) 
                 (S  𝒮. S'  𝒮. fvst S  bvarsst S' = {}) 
                 (S  𝒮. fvst S  bvarsest 𝒜 = {}) 
                 (S  𝒮. fvst (to_st 𝒜)  bvarsst S = {})"

private definition wfsts::"('fun,'var) strands  bool" where
  "wfsts 𝒮  (S  𝒮. wfst {} (dualst S))  (S  𝒮. S'  𝒮. fvst S  bvarsst S' = {})"

private inductive well_analyzed::"('fun,'var) extstrand  bool" where
  Nil[simp]: "well_analyzed []"
| Step: "well_analyzed A  well_analyzed (A@[Step x])"
| Decomp: "well_analyzed A; t  subtermsset (ikest A  assignment_rhsest A) - (Var ` 𝒱)
     well_analyzed (A@[Decomp t])"

private fun subst_apply_extstrandstep (infix "estp" 51) where
  "subst_apply_extstrandstep (Step x) θ = Step (x stp θ)"
| "subst_apply_extstrandstep (Decomp t) θ = Decomp (t  θ)"

private lemma subst_apply_extstrandstep'_simps[simp]:
  "(Step (send⟨tst)) estp θ = Step (send⟨t  θst)"
  "(Step (receive⟨tst)) estp θ = Step (receive⟨t  θst)"
  "(Step (a: t  t'st)) estp θ = Step (a: (t  θ)  (t'  θ)st)"
  "(Step (X⟨∨≠: Fst)) estp θ = Step (X⟨∨≠: (F pairs rm_vars (set X) θ)st)"
by simp_all

private lemma varsestp_subst_apply_simps[simp]:
  "varsestp ((Step (send⟨tst)) estp θ) = fv (t  θ)"
  "varsestp ((Step (receive⟨tst)) estp θ) = fv (t  θ)"
  "varsestp ((Step (a: t  t'st)) estp θ) = fv (t  θ)  fv (t'  θ)"
  "varsestp ((Step (X⟨∨≠: Fst)) estp θ) = set X  fvpairs (F pairs rm_vars (set X) θ)"
by auto

private definition subst_apply_extstrand (infix "est" 51) where "S est θ  map (λx. x estp θ) S"

private abbreviation updatest::"('fun,'var) strands  ('fun,'var) strand  ('fun,'var) strands"
where
  "updatest 𝒮 S  (case S of Nil  𝒮 - {S} | Cons _ S'  insert S' (𝒮 - {S}))"

private inductive_set decompsest::
  "('fun,'var) terms  ('fun,'var) terms  ('fun,'var) subst  ('fun,'var) extstrands"
(* ℳ: intruder knowledge
   𝒩: additional messages
*)
for  and 𝒩 and  where
  Nil: "[]  decompsest  𝒩 "
| Decomp: "𝒟  decompsest  𝒩 ; Fun f T  subtermsset (  𝒩);
            Ana (Fun f T) = (K,M); M  [];
            (  ikest 𝒟) set  c Fun f T  ;
            k. k  set K  (  ikest 𝒟) set  c k  
             𝒟@[Decomp (Fun f T)]  decompsest  𝒩 "

private fun decomp_rmest::"('fun,'var) extstrand  ('fun,'var) extstrand" where
  "decomp_rmest [] = []"
| "decomp_rmest (Decomp t#S) = decomp_rmest S"
| "decomp_rmest (Step x#S) = Step x#(decomp_rmest S)"

private inductive semest_d::"('fun,'var) terms  ('fun,'var) subst  ('fun,'var) extstrand  bool"
where
  Nil[simp]: "semest_d M0  []"
| Send: "semest_d M0  S  (ikest S  M0) set   t    semest_d M0  (S@[Step (send⟨tst)])"
| Receive: "semest_d M0  S  semest_d M0  (S@[Step (receive⟨tst)])"
| Equality: "semest_d M0  S  t   = t'    semest_d M0  (S@[Step (a: t  t'st)])"
| Inequality: "semest_d M0  S
     ineq_model  X F
     semest_d M0  (S@[Step (X⟨∨≠: Fst)])"
| Decompose: "semest_d M0  S  (ikest S  M0) set   t    Ana t = (K, M)
     (k. k  set K  (ikest S  M0) set   k  )  semest_d M0  (S@[Decomp t])"

private inductive semest_c::"('fun,'var) terms  ('fun,'var) subst  ('fun,'var) extstrand  bool"
where
  Nil[simp]: "semest_c M0  []"
| Send: "semest_c M0  S  (ikest S  M0) set  c t    semest_c M0  (S@[Step (send⟨tst)])"
| Receive: "semest_c M0  S  semest_c M0  (S@[Step (receive⟨tst)])"
| Equality: "semest_c M0  S  t   = t'    semest_c M0  (S@[Step (a: t  t'st)])"
| Inequality: "semest_c M0  S
     ineq_model  X F
     semest_c M0  (S@[Step (X⟨∨≠: Fst)])"
| Decompose: "semest_c M0  S  (ikest S  M0) set  c t    Ana t = (K, M)
     (k. k  set K  (ikest S  M0) set  c k  )  semest_c M0  (S@[Decomp t])"


subsubsection ‹Preliminary Lemmata›
private lemma wfsts_wfsts':
  "wfsts 𝒮 = wfsts' 𝒮 []"
by (simp add: wfsts_def wfsts'_def)

private lemma decomp_ik:
  assumes "Ana t = (K,M)"
  shows "ikst (decomp t) = set M"
using ik_rcv_map[of _ M] ik_rcv_map'[of _ M]
by (auto simp add: decomp_def inv_def assms)

private lemma decomp_assignment_rhs_empty:
  assumes "Ana t = (K,M)"
  shows "assignment_rhsst (decomp t) = {}"
by (auto simp add: decomp_def inv_def assms)

private lemma decomp_tfrstp:
  "list_all tfrstp (decomp t)"
by (auto simp add: decomp_def list_all_def)

private lemma trmsest_ikI:
  "t  ikest A  t  subtermsset (trmsest A)"
proof (induction A rule: to_st.induct)
  case (2 x S) thus ?case by (cases x) auto
next
  case (3 t' A)
  obtain K M where Ana: "Ana t' = (K,M)" by (metis surj_pair)
  show ?case using 3 decomp_ik[OF Ana] Ana_subterm[OF Ana] by auto
qed simp

private lemma trmsest_ik_assignment_rhsI:
  "t  ikest A  assignment_rhsest A  t  subtermsset (trmsest A)"
proof (induction A rule: to_st.induct)
  case (2 x S) thus ?case
  proof (cases x)
    case (Equality ac t t') thus ?thesis using 2 by (cases ac) auto
  qed auto
next
  case (3 t' A)
  obtain K M where Ana: "Ana t' = (K,M)" by (metis surj_pair)
  show ?case
    using 3 decomp_ik[OF Ana] decomp_assignment_rhs_empty[OF Ana] Ana_subterm[OF Ana]
    by auto
qed simp

private lemma trmsest_ik_subtermsI:
  assumes "t  subtermsset (ikest A)"
  shows "t  subtermsset (trmsest A)"
proof -
  obtain t' where "t'  ikest A" "t  t'" using trmsest_ikI assms by auto
  thus ?thesis by (meson contra_subsetD in_subterms_subset_Union trmsest_ikI)
qed

private lemma trmsestD:
  assumes "t  trmsest A"
  shows "t  trmsst (to_st A)"
using assms
proof (induction A)
  case (Cons a A)
  obtain K M where Ana: "Ana t = (K,M)" by (metis surj_pair)
  hence "t  trmsst (decomp t)" unfolding decomp_def by force
  thus ?case using Cons.IH Cons.prems by (cases a) auto
qed simp

private lemma subst_apply_extstrand_nil[simp]:
  "[] est θ = []"
by (simp add: subst_apply_extstrand_def)

private lemma subst_apply_extstrand_singleton[simp]:
  "[Step (receive⟨tst)] est θ = [Step (Receive (t  θ))]"
  "[Step (send⟨tst)] est θ = [Step (Send (t  θ))]"
  "[Step (a: t  t'st)] est θ = [Step (Equality a (t  θ) (t'  θ))]"
  "[Decomp t] est θ = [Decomp (t  θ)]"
unfolding subst_apply_extstrand_def by auto

private lemma extstrand_subst_hom:
  "(S@S') est θ = (S est θ)@(S' est θ)" "(x#S) est θ = (x estp θ)#(S est θ)"
unfolding subst_apply_extstrand_def by auto

private lemma decomp_vars:
  "wfrestrictedvarsst (decomp t) = fv t" "varsst (decomp t) = fv t" "bvarsst (decomp t) = {}"
  "fvst (decomp t) = fv t"
proof -
  obtain K M where Ana: "Ana t = (K,M)" by (metis surj_pair)
  hence "decomp t = send⟨tst#map Send K@map Receive M"
    unfolding decomp_def by simp
  moreover have "(set (map fv K)) = fvset (set K)" "(set (map fv M)) = fvset (set M)" by auto
  moreover have "fvset (set K)  fv t" "fvset (set M)  fv t"
    using Ana_subterm[OF Ana(1)] Ana_keys_fv[OF Ana(1)]
    by (simp_all add: UN_least psubsetD subtermeq_vars_subset)
  ultimately show
      "wfrestrictedvarsst (decomp t) = fv t" "varsst (decomp t) = fv t" "bvarsst (decomp t) = {}"
      "fvst (decomp t) = fv t"
    by auto
qed

private lemma bvarsest_cons: "bvarsest (x#X) = bvarsest [x]  bvarsest X"
by (cases x) auto

private lemma bvarsest_append: "bvarsest (A@B) = bvarsest A  bvarsest B"
proof (induction A)
  case (Cons x A) thus ?case using bvarsest_cons[of x "A@B"] bvarsest_cons[of x A] by force
qed simp

private lemma fvest_cons: "fvest (x#X) = fvest [x]  fvest X"
by (cases x) auto

private lemma fvest_append: "fvest (A@B) = fvest A  fvest B"
proof (induction A)
  case (Cons x A) thus ?case using fvest_cons[of x "A@B"] fvest_cons[of x A] by auto
qed simp

private lemma bvars_decomp: "bvarsest (A@[Decomp t]) = bvarsest A" "bvarsest (Decomp t#A) = bvarsest A"
using bvarsest_append decomp_vars(3) by fastforce+

private lemma bvars_decomp_rm: "bvarsest (decomp_rmest A) = bvarsest A"
using bvars_decomp by (induct A rule: decomp_rmest.induct) simp_all+

private lemma fv_decomp_rm: "fvest (decomp_rmest A)  fvest A"
by (induct A rule: decomp_rmest.induct) auto

private lemma ik_assignment_rhs_decomp_fv:
  assumes "t  subtermsset (ikest A  assignment_rhsest A)"
  shows "fvest (A@[Decomp t]) = fvest A"
proof -
  have "fvest (A@[Decomp t]) = fvest A  fv t" using fvest_append decomp_vars by simp
  moreover have "fvset (ikest A  assignment_rhsest A)  fvest A" by force
  moreover have "fv t  fvset (ikest A  assignment_rhsest A)"
    using fv_subset_subterms[OF assms(1)] by simp
  ultimately show ?thesis by blast
qed

private lemma wfrestrictedvarsest_decomp_rmest_subset:
  "wfrestrictedvarsest (decomp_rmest A)  wfrestrictedvarsest A"
by (induct A rule: decomp_rmest.induct) auto+

private lemma wfrestrictedvarsest_eq_wfrestrictedvarsst:
  "wfrestrictedvarsest A = wfrestrictedvarsst (to_st A)"
by simp

private lemma decomp_set_unfold:
  assumes "Ana t = (K, M)"
  shows "set (decomp t) = {send⟨tst}  (Send ` set K)  (Receive ` set M)"
using assms unfolding decomp_def by auto

private lemma ikest_finite: "finite (ikest A)"
by (rule finite_ikst)

private lemma assignment_rhsest_finite: "finite (assignment_rhsest A)"
by (rule finite_assignment_rhsst)

private lemma to_est_append: "to_est (A@B) = to_est A@to_est B"
by (induct A rule: to_est.induct) auto

private lemma to_st_to_est_inv: "to_st (to_est A) = A"
by (induct A rule: to_est.induct) auto

private lemma to_st_append: "to_st (A@B) = (to_st A)@(to_st B)"
by (induct A rule: to_st.induct) auto

private lemma to_st_cons: "to_st (a#B) = (to_st [a])@(to_st B)"
using to_st_append[of "[a]" B] by simp

private lemma wfrestrictedvarsest_split:
  "wfrestrictedvarsest (x#S) = wfrestrictedvarsest [x]  wfrestrictedvarsest S"
  "wfrestrictedvarsest (S@S') = wfrestrictedvarsest S  wfrestrictedvarsest S'"
using to_st_cons[of x S] to_st_append[of S S'] by auto

private lemma ikest_append: "ikest (A@B) = ikest A  ikest B"
by (metis ik_append to_st_append)

private lemma assignment_rhsest_append:
  "assignment_rhsest (A@B) = assignment_rhsest A  assignment_rhsest B"
by (metis assignment_rhs_append to_st_append)

private lemma ikest_cons: "ikest (a#A) = ikest [a]  ikest A"
by (metis ik_append to_st_cons)

private lemma ikest_append_subst:
  "ikest (A@B est θ) = ikest (A est θ)  ikest (B est θ)"
  "ikest (A@B) set θ = (ikest A set θ)  (ikest B set θ)"
by (metis ikest_append extstrand_subst_hom(1), simp add: image_Un to_st_append)

private lemma assignment_rhsest_append_subst:
  "assignment_rhsest (A@B est θ) = assignment_rhsest (A est θ)  assignment_rhsest (B est θ)"
  "assignment_rhsest (A@B) set θ = (assignment_rhsest A set θ)  (assignment_rhsest B set θ)"
by (metis assignment_rhsest_append extstrand_subst_hom(1), use assignment_rhsest_append in blast)

private lemma ikest_cons_subst:
  "ikest (a#A est θ) = ikest ([a estp θ])  ikest (A est θ)"
  "ikest (a#A) set θ = (ikest [a] set θ)  (ikest A set θ)"
by (metis ikest_cons extstrand_subst_hom(2), metis image_Un ikest_cons)

private lemma decomp_rmest_append: "decomp_rmest (S@S') = (decomp_rmest S)@(decomp_rmest S')"
by (induct S rule: decomp_rmest.induct) auto

private lemma decomp_rmest_single[simp]:
  "decomp_rmest [Step (send⟨tst)] = [Step (send⟨tst)]"
  "decomp_rmest [Step (receive⟨tst)] = [Step (receive⟨tst)]"
  "decomp_rmest [Decomp t] = []"
by auto

private lemma decomp_rmest_ik_subset: "ikest (decomp_rmest S)  ikest S"
proof (induction S rule: decomp_rmest.induct)
  case (3 x S) thus ?case by (cases x) auto
qed auto

private lemma decompsest_ik_subset: "D  decompsest M N   ikest D  subtermsset (M  N)"
proof (induction D rule: decompsest.induct)
  case (Decomp D f T K M')
  have "ikst (decomp (Fun f T))  subterms (Fun f T)"
       "ikst (decomp (Fun f T)) = ikest [Decomp (Fun f T)]"
    using decomp_ik[OF Decomp.hyps(3)] Ana_subterm[OF Decomp.hyps(3)]
    by auto
  hence "ikst (to_st [Decomp (Fun f T)])  subtermsset (M  N)"
    using in_subterms_subset_Union[OF Decomp.hyps(2)]
    by blast
  thus ?case using ikest_append[of D "[Decomp (Fun f T)]"] using Decomp.IH by auto
qed simp

private lemma decompsest_decomp_rmest_empty: "D  decompsest M N   decomp_rmest D = []"
by (induct D rule: decompsest.induct) (auto simp add: decomp_rmest_append)

private lemma decompsest_append:
  assumes "A  decompsest S N " "B  decompsest S N "
  shows "A@B  decompsest S N "
using assms(2)
proof (induction B rule: decompsest.induct)
  case Nil show ?case using assms(1) by simp
next
  case (Decomp B f X K T)
  hence "S  ikest B set   S  ikest (A@B) set " using ikest_append by auto
  thus ?case
    using decompsest.Decomp[OF Decomp.IH(1) Decomp.hyps(2,3,4)]
          ideduct_synth_mono[OF Decomp.hyps(5)]
          ideduct_synth_mono[OF Decomp.hyps(6)]
    by auto
qed

private lemma decompsest_subterms:
  assumes "A'  decompsest M N "
  shows "subtermsset (ikest A')  subtermsset (M  N)"
using assms
proof (induction A' rule: decompsest.induct)
  case (Decomp D f X K T)
  hence "Fun f X  subtermsset (M  N)" by auto
  hence "subtermsset (set X)  subtermsset (M  N)"
    using in_subterms_subset_Union[of "Fun f X" "M  N"] params_subterms_Union[of X f]
    by blast
  moreover have "ikst (to_st [Decomp (Fun f X)]) = set T" using Decomp.hyps(3) decomp_ik by simp
  hence "subtermsset (ikst (to_st [Decomp (Fun f X)]))  subtermsset (set X)"
    using Ana_fun_subterm[OF Decomp.hyps(3)] by auto
  ultimately show ?case
    using ikest_append[of D "[Decomp (Fun f X)]"] Decomp.IH
    by auto
qed simp

private lemma decompsest_assignment_rhs_empty:
  assumes "A'  decompsest M N "
  shows "assignment_rhsest A' = {}"
using assms
by (induction A' rule: decompsest.induct)
   (simp_all add: decomp_assignment_rhs_empty assignment_rhsest_append)

private lemma decompsest_finite_ik_append:
  assumes "finite M" "M  decompsest A N "
  shows "D  decompsest A N . ikest D = (m  M. ikest m)"
using assms
proof (induction M rule: finite_induct)
  case empty
  moreover have "[]  decompsest A N " "ikst (to_st []) = {}" using decompsest.Nil by auto
  ultimately show ?case by blast
next
  case (insert m M)
  then obtain D where "D  decompsest A N " "ikest D = (mM. ikst (to_st m))" by moura
  moreover have "m  decompsest A N " using insert.prems(1) by blast
  ultimately show ?case using decompsest_append[of D A N  m] ikest_append[of D m] by blast
qed

private lemma decomp_snd_exists[simp]: "D. decomp t = send⟨tst#D"
by (metis (mono_tags, lifting) decomp_def prod.case surj_pair)

private lemma decomp_nonnil[simp]: "decomp t  []"
using decomp_snd_exists[of t] by fastforce

private lemma to_st_nil_inv[dest]: "to_st A = []  A = []"
by (induct A rule: to_st.induct) auto

private lemma well_analyzedD:
  assumes "well_analyzed A" "Decomp t  set A"
  shows "f T. t = Fun f T"
using assms
proof (induction A rule: well_analyzed.induct)
  case (Decomp A t')
  hence "f T. t' = Fun f T" by (cases t') auto
  moreover have "Decomp t  set A  t = t'" using Decomp by auto
  ultimately show ?case using Decomp.IH by auto
qed auto

private lemma well_analyzed_inv:
  assumes "well_analyzed (A@[Decomp t])"
  shows "t  subtermsset (ikest A  assignment_rhsest A) - (Var ` 𝒱)"
using assms well_analyzed.cases[of "A@[Decomp t]"] by fastforce

private lemma well_analyzed_split_left_single: "well_analyzed (A@[a])  well_analyzed A"
by (induction "A@[a]" rule: well_analyzed.induct) auto

private lemma well_analyzed_split_left: "well_analyzed (A@B)  well_analyzed A"
proof (induction B rule: List.rev_induct)
  case (snoc b B) thus ?case using well_analyzed_split_left_single[of "A@B" b] by simp
qed simp

private lemma well_analyzed_append:
  assumes "well_analyzed A" "well_analyzed B"
  shows "well_analyzed (A@B)"
using assms(2,1)
proof (induction B rule: well_analyzed.induct)
  case (Step B x) show ?case using well_analyzed.Step[OF Step.IH[OF Step.prems]] by simp
next
  case (Decomp B t) thus ?case
    using well_analyzed.Decomp[OF Decomp.IH[OF Decomp.prems]] ikest_append assignment_rhsest_append
    by auto
qed simp_all

private lemma well_analyzed_singleton:
  "well_analyzed [Step (send⟨tst)]" "well_analyzed [Step (receive⟨tst)]"
  "well_analyzed [Step (a: t  t'st)]" "well_analyzed [Step (X⟨∨≠: Fst)]"
  "¬well_analyzed [Decomp t]"
proof -
  show "well_analyzed [Step (send⟨tst)]" "well_analyzed [Step (receive⟨tst)]"
       "well_analyzed [Step (a: t  t'st)]" "well_analyzed [Step (X⟨∨≠: Fst)]"
    using well_analyzed.Step[OF well_analyzed.Nil]
    by simp_all

  show "¬well_analyzed [Decomp t]" using well_analyzed.cases[of "[Decomp t]"] by auto
qed

private lemma well_analyzed_decomp_rmest_fv: "well_analyzed A  fvest (decomp_rmest A) = fvest A"
proof
  assume "well_analyzed A" thus "fvest A  fvest (decomp_rmest A)"
  proof (induction A rule: well_analyzed.induct)
    case Decomp thus ?case using ik_assignment_rhs_decomp_fv decomp_rmest_append by auto
  next
    case (Step A x)
    have "fvest (A@[Step x]) = fvest A  fvstp x"
         "fvest (decomp_rmest (A@[Step x])) = fvest (decomp_rmest A)  fvstp x"
      using fvest_append decomp_rmest_append by auto
    thus ?case using Step by auto
  qed simp
qed (rule fv_decomp_rm)

private lemma semest_d_split_left: assumes "semest_d M0  (𝒜@𝒜')" shows "semest_d M0  𝒜"
using assms semest_d.cases by (induction 𝒜' rule: List.rev_induct) fastforce+

private lemma semest_d_eq_sem_st: "semest_d M0  𝒜 = M0; to_st 𝒜d' "
proof
  show "M0; to_st 𝒜d'   semest_d M0  𝒜"
  proof (induction 𝒜 arbitrary: M0 rule: List.rev_induct)
    case Nil show ?case using to_st_nil_inv by simp
  next
    case (snoc a 𝒜)
    hence IH: "semest_d M0  𝒜" and *: "ikest 𝒜  M0; to_st [a]d' "
      using to_st_append by (auto simp add: sup.commute)
    thus ?case using snoc
    proof (cases a)
      case (Step b) thus ?thesis
      proof (cases b)
        case (Send t) thus ?thesis using semest_d.Send[OF IH] * Step by auto
      next
        case (Receive t) thus ?thesis using semest_d.Receive[OF IH] Step by auto
      next
        case (Equality a t t') thus ?thesis using semest_d.Equality[OF IH] * Step by auto
      next
        case (Inequality X F) thus ?thesis using semest_d.Inequality[OF IH] * Step by auto
      qed
    next
      case (Decomp t)
      obtain K M where Ana: "Ana t = (K,M)" by moura
      have "to_st [a] = decomp t" using Decomp by auto
      hence "to_st [a] = send⟨tst#map Send K@map Receive M"
        using Ana unfolding decomp_def by auto
      hence **: "ikest 𝒜  M0 set   t  " and "ikest 𝒜  M0; map Send Kd' "
        using * by auto
      hence "k. k  set K  ikest 𝒜  M0 set   k  "
        using *
        by (metis (full_types) strand_sem_d.simps(2) strand_sem_eq_defs(2) strand_sem_Send_split(2))
      thus ?thesis using Decomp semest_d.Decompose[OF IH ** Ana] by metis
    qed
  qed

  show "semest_d M0  𝒜  M0; to_st 𝒜d' "
  proof (induction rule: semest_d.induct)
    case Nil thus ?case by simp
  next
    case (Send M0  𝒜 t) thus ?case
      using strand_sem_append'[of M0 "to_st 𝒜"  "[send⟨tst]"]
            to_st_append[of 𝒜 "[Step (send⟨tst)]"]
      by (simp add: sup.commute)
  next
    case (Receive M0  𝒜 t) thus ?case
      using strand_sem_append'[of M0 "to_st 𝒜"  "[receive⟨tst]"]
            to_st_append[of 𝒜 "[Step (receive⟨tst)]"]
      by (simp add: sup.commute)
  next
    case (Equality M0  𝒜 t t' a) thus ?case
      using strand_sem_append'[of M0 "to_st 𝒜"  "[a: t  t'st]"]
            to_st_append[of 𝒜 "[Step (a: t  t'st)]"]
      by (simp add: sup.commute)
  next
    case (Inequality M0  𝒜 X F) thus ?case
      using strand_sem_append'[of M0 "to_st 𝒜"  "[X⟨∨≠: Fst]"]
            to_st_append[of 𝒜 "[Step (X⟨∨≠: Fst)]"]
      by (simp add: sup.commute)
  next
    case (Decompose M0  𝒜 t K M)
    have "M0  ikst (to_st 𝒜); decomp td' "
    proof -
      have "M0  ikst (to_st 𝒜); [send⟨tst]d' "
        using Decompose.hyps(2) by (auto simp add: sup.commute)
      moreover have "k. k  set K  M0  ikst (to_st 𝒜) set   k  "
        using Decompose by (metis sup.commute)
      hence "k. k  set K  M0  ikst (to_st 𝒜); [Send k]d' " by auto
      hence "M0  ikst (to_st 𝒜); map Send Kd' "
        using strand_sem_Send_map(2)[of K, of "M0  ikst (to_st 𝒜) set " ] strand_sem_eq_defs(2)
        by auto
      moreover have "M0  ikst (to_st 𝒜); map Receive Md' "
        by (metis strand_sem_Receive_map(2) strand_sem_eq_defs(2))
      ultimately have
          "M0  ikst (to_st 𝒜); send⟨tst#map Send K@map Receive Md' "
        by auto
      thus ?thesis using Decompose.hyps(3) unfolding decomp_def by auto
    qed
    hence "M0; to_st 𝒜@decomp td' "
      using strand_sem_append'[of M0 "to_st 𝒜"  "decomp t"] Decompose.IH
      by simp
    thus ?case using to_st_append[of 𝒜 "[Decomp t]"] by simp
  qed
qed

private lemma semest_c_eq_sem_st: "semest_c M0  𝒜 = M0; to_st 𝒜c' "
proof
  show "M0; to_st 𝒜c'   semest_c M0  𝒜"
  proof (induction 𝒜 arbitrary: M0 rule: List.rev_induct)
    case Nil show ?case using to_st_nil_inv by simp
  next
    case (snoc a 𝒜)
    hence IH: "semest_c M0  𝒜" and *: "ikest 𝒜  M0; to_st [a]c' "
      using to_st_append
      by (auto simp add: sup.commute)
    thus ?case using snoc
    proof (cases a)
      case (Step b) thus ?thesis
      proof (cases b)
        case (Send t) thus ?thesis using semest_c.Send[OF IH] * Step by auto
      next
        case (Receive t) thus ?thesis using semest_c.Receive[OF IH] Step by auto
      next
        case (Equality t) thus ?thesis using semest_c.Equality[OF IH] * Step by auto
      next
        case (Inequality t) thus ?thesis using semest_c.Inequality[OF IH] * Step by auto
      qed
    next
      case (Decomp t)
      obtain K M where Ana: "Ana t = (K,M)" by moura
      have "to_st [a] = decomp t" using Decomp by auto
      hence "to_st [a] = send⟨tst#map Send K@map Receive M"
        using Ana unfolding decomp_def by auto
      hence **: "ikest 𝒜  M0 set  c t  " and "ikest 𝒜  M0; map Send Kc' "
        using * by auto
      hence "k. k  set K  ikest 𝒜  M0 set  c k  "
        using * strand_sem_Send_split(1) strand_sem_eq_defs(1)
        by auto
      thus ?thesis using Decomp semest_c.Decompose[OF IH ** Ana] by metis
    qed
  qed

  show "semest_c M0  𝒜  M0; to_st 𝒜c' "
  proof (induction rule: semest_c.induct)
    case Nil thus ?case by simp
  next
    case (Send M0  𝒜 t) thus ?case
      using strand_sem_append'[of M0 "to_st 𝒜"  "[send⟨tst]"]
            to_st_append[of 𝒜 "[Step (send⟨tst)]"]
      by (simp add: sup.commute)
  next
    case (Receive M0  𝒜 t) thus ?case
      using strand_sem_append'[of M0 "to_st 𝒜"  "[receive⟨tst]"]
            to_st_append[of 𝒜 "[Step (receive⟨tst)]"]
      by (simp add: sup.commute)
  next
    case (Equality M0  𝒜 t t' a) thus ?case
      using strand_sem_append'[of M0 "to_st 𝒜"  "[a: t  t'st]"]
            to_st_append[of 𝒜 "[Step (a: t  t'st)]"]
      by (simp add: sup.commute)
  next
    case (Inequality M0  𝒜 X F) thus ?case
      using strand_sem_append'[of M0 "to_st 𝒜"  "[X⟨∨≠: Fst]"]
            to_st_append[of 𝒜 "[Step (X⟨∨≠: Fst)]"]
      by (auto simp add: sup.commute)
  next
    case (Decompose M0  𝒜 t K M)
    have "M0  ikst (to_st 𝒜); decomp tc' "
    proof -
      have "M0  ikst (to_st 𝒜); [send⟨tst]c' "
        using Decompose.hyps(2) by (auto simp add: sup.commute)
      moreover have "k. k  set K  M0  ikst (to_st 𝒜) set  c k  "
        using Decompose by (metis sup.commute)
      hence "k. k  set K  M0  ikst (to_st 𝒜); [Send k]c' " by auto
      hence "M0  ikst (to_st 𝒜); map Send Kc' "
        using strand_sem_Send_map(1)[of K, of "M0  ikst (to_st 𝒜) set " ]
              strand_sem_eq_defs(1)
        by auto
      moreover have "M0  ikst (to_st 𝒜); map Receive Mc' "
        by (metis strand_sem_Receive_map(1) strand_sem_eq_defs(1))
      ultimately have
          "M0  ikst (to_st 𝒜); send⟨tst#map Send K@map Receive Mc' "
        by auto
      thus ?thesis using Decompose.hyps(3) unfolding decomp_def by auto
    qed
    hence "M0; to_st 𝒜@decomp tc' "
      using strand_sem_append'[of M0 "to_st 𝒜"  "decomp t"] Decompose.IH
      by simp
    thus ?case using to_st_append[of 𝒜 "[Decomp t]"] by simp
  qed
qed

private lemma semest_c_decomp_rmest_deduct_aux:
  assumes "semest_c M0  A" "t  ikest A set " "t  ikest (decomp_rmest A) set "
  shows "ikest (decomp_rmest A)  M0 set   t"
using assms
proof (induction M0  A arbitrary: t rule: semest_c.induct)
  case (Send M0  A t') thus ?case using decomp_rmest_append ikest_append by auto
next
  case (Receive M0  A t')
  hence "t  ikest A set " "t  ikest (decomp_rmest A) set "
    using decomp_rmest_append ikest_append by auto
  hence IH: "ikest (decomp_rmest A)  M0 set   t" using Receive.IH by auto
  show ?case using ideduct_mono[OF IH] decomp_rmest_append ikest_append by auto
next
  case (Equality M0  A t') thus ?case using decomp_rmest_append ikest_append by auto
next
  case (Inequality M0  A t') thus ?case using decomp_rmest_append ikest_append by auto
next
  case (Decompose M0  A t' K M t)
  have *: "ikest (decomp_rmest A)  M0 set   t'  " using Decompose.hyps(2)
  proof (induction rule: intruder_synth_induct)
    case (AxiomC t'')
    moreover {
      assume "t''  ikest A set " "t''  ikest (decomp_rmest A) set "
      hence ?case using Decompose.IH by auto
    }
    ultimately show ?case by force
  qed simp

  { fix k assume "k  set K"
    hence "ikest A  M0 set  c k  " using Decompose.hyps by auto
    hence "ikest (decomp_rmest A)  M0 set   k  "
    proof (induction rule: intruder_synth_induct)
      case (AxiomC t'')
      moreover {
        assume "t''  ikest A set " "t''  ikest (decomp_rmest A) set "
        hence ?case using Decompose.IH by auto
      }
      ultimately show ?case by force
    qed simp
  }
  hence **: "k. k  set (K list )  ikest (decomp_rmest A)  M0 set   k" by auto

  show ?case
  proof (cases "t  ikest A set ")
    case True thus ?thesis using Decompose.IH Decompose.prems(2) decomp_rmest_append by auto
  next
    case False
    hence "t  ikst (decomp t') set " using Decompose.prems(1) ikest_append by auto
    hence ***: "t  set (M list )" using Decompose.hyps(3) decomp_ik by auto
    hence "M  []" by auto
    hence ****: "Ana (t'  ) = (K list , M list )" using Ana_subst[OF Decompose.hyps(3)] by auto

    have "ikest (decomp_rmest A)  M0 set   t" by (rule intruder_deduct.Decompose[OF * **** ** ***])
    thus ?thesis using ideduct_mono decomp_rmest_append by auto
  qed
qed simp

private lemma semest_c_decomp_rmest_deduct:
  assumes "semest_c M0  A" "ikest A  M0 set  c t"
  shows "ikest (decomp_rmest A)  M0 set   t"
using assms(2)
proof (induction t rule: intruder_synth_induct)
  case (AxiomC t)
  hence "t  ikest A set   t  M0 set " by auto
  moreover {
    assume "t  ikest A set " "t  ikest (decomp_rmest A) set "
    hence ?case using ideduct_mono[OF intruder_deduct.Axiom] by auto
  }
  moreover {
    assume "t  ikest A set " "t  ikest (decomp_rmest A) set "
    hence ?case using semest_c_decomp_rmest_deduct_aux[OF assms(1)] by auto
  }
  ultimately show ?case by auto
qed simp

private lemma semest_d_decomp_rmest_if_semest_c: "semest_c M0  A  semest_d M0  (decomp_rmest A)"
proof (induction M0  A rule: semest_c.induct)
  case (Send M0  A t)
  thus ?case using decomp_rmest_append semest_d.Send[OF Send.IH] semest_c_decomp_rmest_deduct by auto
next
  case (Receive t) thus ?case using decomp_rmest_append semest_d.Receive by auto
next
  case (Equality M0  A t)
  thus ?case
    using decomp_rmest_append semest_d.Equality[OF Equality.IH] semest_c_decomp_rmest_deduct
    by auto
next
  case (Inequality M0  A t)
  thus ?case
    using decomp_rmest_append semest_d.Inequality[OF Inequality.IH] semest_c_decomp_rmest_deduct
    by auto
next
  case Decompose thus ?case using decomp_rmest_append by auto
qed auto

private lemma semest_c_decompsest_append:
  assumes "semest_c {}  A" "D  decompsest (ikest A) (assignment_rhsest 𝒜) "
  shows "semest_c {}  (A@D)"
using assms(2,1)
proof (induction D rule: decompsest.induct)
  case (Decomp D f T K M)
  hence *: "semest_c {}  (A @ D)" "ikest (A@D)  {} set  c Fun f T  "
           "k. k  set K  ikest (A @ D)  {} set  c k  "
    using ikest_append by auto
  show ?case using semest_c.Decompose[OF *(1,2) Decomp.hyps(3) *(3)] by simp
qed auto

private lemma decompsest_preserves_wf:
  assumes "D  decompsest (ikest A) (assignment_rhsest A) " "wfest V A"
  shows "wfest V (A@D)"
using assms
proof (induction D rule: decompsest.induct)
  case (Decomp D f T K M)
  have "wfrestrictedvarsst (decomp (Fun f T))  fvset (ikest A  assignment_rhsest A)"
    using decomp_vars fv_subset_subterms[OF Decomp.hyps(2)] by fast
  hence "wfrestrictedvarsst (decomp (Fun f T))  wfrestrictedvarsest A"
    using ikst_assignment_rhsst_wfrestrictedvars_subset[of "to_st A"] by blast
  hence "wfrestrictedvarsst (decomp (Fun f T))  wfrestrictedvarsst (to_st (A@D))  V"
    using to_st_append[of A D] strand_vars_split(2)[of "to_st A" "to_st D"]
    by (metis le_supI1)
  thus ?case
    using wf_append_suffix[OF Decomp.IH[OF Decomp.prems], of "decomp (Fun f T)"]
          to_st_append[of "A@D" "[Decomp (Fun f T)]"]
    by auto
qed auto

private lemma decompsest_preserves_model_c:
  assumes "D  decompsest (ikest A) (assignment_rhsest A) " "semest_c M0  A"
  shows "semest_c M0  (A@D)"
using assms
proof (induction D rule: decompsest.induct)
  case (Decomp D f T K M) show ?case
    using semest_c.Decompose[OF Decomp.IH[OF Decomp.prems] _ Decomp.hyps(3)]
          Decomp.hyps(5,6) ideduct_synth_mono ikest_append
    by (metis (mono_tags, lifting) List.append_assoc image_Un sup_ge1)
qed auto

private lemma decompsest_exist_aux:
  assumes "D  decompsest M N " "M  ikest D  t" "¬(M  (ikest D) c t)"
  obtains D' where
    "D@D'  decompsest M N " "M  ikest (D@D') c t" "M  ikest D  M  ikest (D@D')"
proof -
  have "D'  decompsest M N . M  ikest D' c t" using assms(2)
  proof (induction t rule: intruder_deduct_induct)
    case (Compose X f)
    from Compose.IH have "D  decompsest M N . x  set X. M  ikest D c x"
    proof (induction X)
      case (Cons t X)
      then obtain D' D'' where
          D': "D'  decompsest M N " "M  ikest D' c t" and
          D'': "D''  decompsest M N " "x  set X. M  ikest D'' c x"
        by moura
      hence "M  ikest (D'@D'') c t" "x  set X. M  ikest (D'@D'') c x"
        by (auto intro: ideduct_synth_mono simp add: ikest_append)
      thus ?case using decompsest_append[OF D'(1) D''(1)] by (metis set_ConsD)
    qed (auto intro: decompsest.Nil)
    thus ?case using intruder_synth.ComposeC[OF Compose.hyps(1,2)] by metis
  next
    case (Decompose t K T ti)
    have "D  decompsest M N . k  set K. M  ikest D c k" using Decompose.IH
    proof (induction K)
      case (Cons t X)
      then obtain D' D'' where
          D': "D'  decompsest M N " "M  ikest D' c t" and
          D'': "D''  decompsest M N " "x  set X. M  ikest D'' c x"
        using assms(1) by moura
      hence "M  ikest (D'@D'') c t" "x  set X. M  ikest (D'@D'') c x"
        by (auto intro: ideduct_synth_mono simp add: ikest_append)
      thus ?case using decompsest_append[OF D'(1) D''(1)] by auto
    qed auto
    then obtain D' where D': "D'  decompsest M N " "k. k  set K  M  ikest D' c k" by metis
    obtain D'' where D'': "D''  decompsest M N " "M  ikest D'' c t" by (metis Decompose.IH(1))
    obtain f X where fX: "t = Fun f X" "ti  set X"
      using Decompose.hyps(2,4) by (cases t) (auto dest: Ana_fun_subterm)

    from decompsest_append[OF D'(1) D''(1)] D'(2) D''(2) have *:
        "D'@D''  decompsest M N " "k. k  set K  M  ikest (D'@D'') c k"
        "M  ikest (D'@D'') c t"
      by (auto intro: ideduct_synth_mono simp add: ikest_append)
    hence **: "k. k  set K  M  ikest (D'@D'') set  c k  "
      using ideduct_synth_subst by auto

    have "ti  ikst (decomp t)" using Decompose.hyps(2,4) ik_rcv_map unfolding decomp_def by auto
    with *(3) fX(1) Decompose.hyps(2) show ?case
    proof (induction t rule: intruder_synth_induct)
      case (AxiomC t)
      hence t_in_subterms: "t  subtermsset (M  N)"
        using decompsest_ik_subset[OF *(1)] subset_subterms_Union
        by auto
      have "M  ikest (D'@D'') set  c t  "
        using ideduct_synth_subst[OF intruder_synth.AxiomC[OF AxiomC.hyps(1)]] by metis
      moreover have "T  []" using decomp_ik[OF Ana t = (K,T)] ti  ikst (decomp t) by auto
      ultimately have "D'@D''@[Decomp (Fun f X)]  decompsest M N "
        using AxiomC decompsest.Decomp[OF *(1) _ _ _ _ **] subset_subterms_Union t_in_subterms
        by (simp add: subset_eq)
      moreover have "decomp t = to_st [Decomp (Fun f X)]" using AxiomC.prems(1,2) by auto
      ultimately show ?case
        by (metis AxiomC.prems(3) UnCI intruder_synth.AxiomC ikest_append to_st_append)
    qed (auto intro!: fX(2) *(1))
  qed (fastforce intro: intruder_synth.AxiomC assms(1))
  hence "D'  decompsest M N . M  ikest (D@D') c t"
    by (auto intro: ideduct_synth_mono simp add: ikest_append)
  thus thesis using that[OF decompsest_append[OF assms(1)]] assms ikest_append by moura
qed

private lemma decompsest_ik_max_exist:
  assumes "finite A" "finite N"
  shows "D  decompsest A N . D'  decompsest A N . ikest D'  ikest D"
proof -
  let ?IK = "λM. D  M. ikest D"
  have "?IK (decompsest A N )  (t  A  N. subterms t)" by (auto dest!: decompsest_ik_subset)
  hence "finite (?IK (decompsest A N ))"
    using subterms_union_finite[OF assms(1)] subterms_union_finite[OF assms(2)] infinite_super
    by auto
  then obtain M where M: "finite M" "M  decompsest A N " "?IK M = ?IK (decompsest A N )"
    using finite_subset_Union by moura
  show ?thesis using decompsest_finite_ik_append[OF M(1,2)] M(3) by auto
qed

private lemma decompsest_exist:
  assumes "finite A" "finite N"
  shows "D  decompsest A N . t. A  t  A  ikest D c t"
proof (rule ccontr)
  assume neg: "¬(D  decompsest A N . t. A  t  A  ikest D c t)"

  obtain D where D: "D  decompsest A N " "D'  decompsest A N . ikest D'  ikest D"
    using decompsest_ik_max_exist[OF assms] by moura
  then obtain t where t: "A  ikest D  t" "¬(A  ikest D c t)"
    using neg by (fastforce intro: ideduct_mono)

  obtain D' where D':
      "D@D'  decompsest A N " "A  ikest (D@D') c t"
      "A  ikest D  A  ikest (D@D')"
    by (metis decompsest_exist_aux t D(1))
  hence "ikest D  ikest (D@D')" using ikest_append by auto
  moreover have "ikest (D@D')  ikest D" using D(2) D'(1) by auto
  ultimately show False by simp
qed

private lemma decompsest_exist_subst:
  assumes "ikest A set   t  "
  and "semest_c {}  A" "wfest {} A" "interpretationsubst "
  and "Ana_invar_subst (ikest A  assignment_rhsest A)"
  and "well_analyzed A"
  shows "D  decompsest (ikest A) (assignment_rhsest A) . ikest (A@D) set  c t  "
proof -
  have ik_eq: "ikest (A est ) = ikest A set " using assms(5,6)
  proof (induction A rule: List.rev_induct)
    case (snoc a A)
    hence "Ana_invar_subst (ikest A  assignment_rhsest A)"
      using Ana_invar_subst_subset[OF snoc.prems(1)] ikest_append assignment_rhsest_append
      unfolding Ana_invar_subst_def by simp
    with snoc have IH:
        "ikest (A@[a] est ) = (ikest A set )  ikest ([a] est )"
        "ikest (A@[a]) set  = (ikest A set )  (ikest [a] set )"
      using well_analyzed_split_left[OF snoc.prems(2)]
      by (auto simp add: to_st_append ikest_append_subst)

    have "ikest [a estp ] = ikest [a] set "
    proof (cases a)
      case (Step b) thus ?thesis by (cases b) auto
    next
      case (Decomp t)
      then obtain f T where t: "t = Fun f T" using well_analyzedD[OF snoc.prems(2)] by force
      obtain K M where Ana_t: "Ana (Fun f T) = (K,M)" by (metis surj_pair)
      moreover have "Fun f T  subtermsset ((ikest (A@[a])  assignment_rhsest (A@[a])))"
        using t Decomp snoc.prems(2)
        by (auto dest: well_analyzed_inv simp add: ikest_append assignment_rhsest_append)
      hence "Ana (Fun f T  ) = (K list , M list )"
        using Ana_t snoc.prems(1)
        unfolding Ana_invar_subst_def by blast
      ultimately show ?thesis using Decomp t by (auto simp add: decomp_ik)
    qed
    thus ?case using IH unfolding subst_apply_extstrand_def by simp
  qed simp
  moreover have assignment_rhs_eq: "assignment_rhsest (A est ) = assignment_rhsest A set "
    using assms(5,6)
  proof (induction A rule: List.rev_induct)
    case (snoc a A)
    hence "Ana_invar_subst (ikest A  assignment_rhsest A)"
      using Ana_invar_subst_subset[OF snoc.prems(1)] ikest_append assignment_rhsest_append
      unfolding Ana_invar_subst_def by simp
    hence "assignment_rhsest (A est ) = assignment_rhsest A set "
      using snoc.IH well_analyzed_split_left[OF snoc.prems(2)]
      by simp
    hence IH:
        "assignment_rhsest (A@[a] est ) = (assignment_rhsest A set )  assignment_rhsest ([a] est )"
        "assignment_rhsest (A@[a]) set  = (assignment_rhsest A set )  (assignment_rhsest [a] set )"
      by (metis assignment_rhsest_append_subst(1), metis assignment_rhsest_append_subst(2))

    have "assignment_rhsest [a estp ] = assignment_rhsest [a] set "
    proof (cases a)
      case (Step b) thus ?thesis by (cases b) auto
    next
      case (Decomp t)
      then obtain f T where t: "t = Fun f T" using well_analyzedD[OF snoc.prems(2)] by force
      obtain K M where Ana_t: "Ana (Fun f T) = (K,M)" by (metis surj_pair)
      moreover have "Fun f T  subtermsset ((ikest (A@[a])  assignment_rhsest (A@[a])))"
        using t Decomp snoc.prems(2)
        by (auto dest: well_analyzed_inv simp add: ikest_append assignment_rhsest_append)
      hence "Ana (Fun f T  ) = (K list , M list )"
        using Ana_t snoc.prems(1) unfolding Ana_invar_subst_def by blast
      ultimately show ?thesis using Decomp t by (auto simp add: decomp_assignment_rhs_empty)
    qed
    thus ?case using IH unfolding subst_apply_extstrand_def by simp
  qed simp
  ultimately obtain D where D:
      "D  decompsest (ikest A set ) (assignment_rhsest A set ) Var"
      "(ikest A set )  (ikest D) c t  "
    using decompsest_exist[OF ikest_finite assignment_rhsest_finite, of "A est " "A est "]
          ikest_append assignment_rhsest_append assms(1)
    by force

  let ?P = "λD D'. t. (ikest A set )  (ikest D) c t  (ikest A set )  (ikest D' set ) c t"

  have "D'  decompsest (ikest A) (assignment_rhsest A) . ?P D D'" using D(1)
  proof (induction D rule: decompsest.induct)
    case Nil
    have "ikest [] = ikest [] set " by auto
    thus ?case by (metis decompsest.Nil)
  next
    case (Decomp D f T K M)
    obtain D' where D': "D'  decompsest (ikest A) (assignment_rhsest A) " "?P D D'"
      using Decomp.IH by auto
    hence IH: "k. k  set K  (ikest A set )  (ikest D' set ) c k"
              "(ikest A set )  (ikest D' set ) c Fun f T"
      using Decomp.hyps(5,6) by auto

    have D'_ik: "ikest D' set   subtermsset ((ikest A  assignment_rhsest A)) set "
                "ikest D'  subtermsset (ikest A  assignment_rhsest A)"
      using decompsest_ik_subset[OF D'(1)] by (metis subst_all_mono, metis)

    show ?case using IH(2,1) Decomp.hyps(2,3,4)
    proof (induction "Fun f T" arbitrary: f T K M rule: intruder_synth_induct)
      case (AxiomC f T)
      then obtain s where s: "s  ikest A  ikest D'" "Fun f T = s  " using AxiomC.prems by blast
      hence fT_s_in: "Fun f T  (subtermsset (ikest A  assignment_rhsest A)) set "
                     "s  subtermsset (ikest A  assignment_rhsest A)"
        using AxiomC D'_ik subset_subterms_Union[of "ikest A  assignment_rhsest A"]
              subst_all_mono[OF subset_subterms_Union, of ]
        by (metis (no_types) Un_iff image_eqI subset_Un_eq, metis (no_types) Un_iff subset_Un_eq)
      obtain Ks Ms where Ana_s: "Ana s = (Ks,Ms)" by moura

      have AD'_props: "wfest {} (A@D')" "{}; to_st (A@D')c "
        using decompsest_preserves_model_c[OF D'(1) assms(2)]
              decompsest_preserves_wf[OF D'(1) assms(3)]
              semest_c_eq_sem_st strand_sem_eq_defs(1)
        by auto

      show ?case
      proof (cases s)
        case (Var x)
        ― ‹In this case ℐ x› (is a subterm of something that) was derived from an
            "earlier intruder knowledge" because A› is well-formed and has ℐ› as a model.
            So either the intruder composed Fun f T› himself (making Decomp (Fun f T)›
            unnecessary) or Fun f T› is an instance of something else in the intruder
            knowledge (in which case the "something" can be used in place of Fun f T›)›
        hence "Var x  ikest (A@D')" " x = Fun f T" using s ikest_append by auto

        show ?thesis
        proof (cases "m  set M. ikest A  ikest D' set  c m")
          case True
          ― ‹All terms acquired by decomposing Fun f T› are already derivable.
              Hence there is no need to consider decomposition of Fun f T› at all.›
          have *: "(ikest A set )  ikest (D@[Decomp (Fun f T)]) = (ikest A set )  ikest D  set M"
            using decomp_ik[OF Ana (Fun f T) = (K,M)] ikest_append[of D "[Decomp (Fun f T)]"]
            by auto

          { fix t' assume "(ikest A set )  ikest D  set M c t'"
            hence "(ikest A set )  (ikest D' set ) c t'"
            proof (induction t' rule: intruder_synth_induct)
              case (AxiomC t') thus ?case
              proof
                assume "t'  set M"
                moreover have "(ikest A set )  (ikest D' set ) = ikest A  ikest D' set " by auto
                ultimately show ?case using True by auto
              qed (metis D'(2) intruder_synth.AxiomC)
            qed auto
          }
          thus ?thesis using D'(1) * by metis
        next
          case False
          ― ‹Some term acquired by decomposition of Fun f T› cannot be derived in c.
              Fun f T› must therefore be an instance of something else in the intruder knowledge,
              because of well-formedness.›
          then obtain ti where ti: "ti  set T" "¬ikest (A@D') set  c ti"
            using Ana_fun_subterm[OF Ana (Fun f T) = (K,M)] by (auto simp add: ikest_append)
          obtain S where fS:
              "Fun f S  subtermsset (ikest (A@D')) 
               Fun f S  subtermsset (assignment_rhsest (A@D'))"
              " x = Fun f S  "
            using strand_sem_wf_ik_or_assignment_rhs_fun_subterm[
                    OF AD'_props ‹Var x  ikest (A@D') _ ti ‹interpretationsubst ]
                   x = Fun f T
            by moura
          hence fS_in: "Fun f S    ikest A  ikest D' set "
                       "Fun f S  subtermsset (ikest A  assignment_rhsest A)"
            using imageI[OF s(1), of "λx. x  "] Var
                  ikest_append[of A D'] assignment_rhsest_append[of A D']
                  decompsest_subterms[OF D'(1)] decompsest_assignment_rhs_empty[OF D'(1)]
            by auto
          obtain KS MS where Ana_fS: "Ana (Fun f S) = (KS, MS)" by moura
          hence "K = KS list " "M = MS list "
            using Ana_invar_substD[OF assms(5) fS_in(2)]
                  s(2) fS(2) s = Var x Ana (Fun f T) = (K,M)
            by simp_all
          hence "MS  []" using M  [] by simp
          have "k. k  set KS  ikest A  ikest D' set  c k  "
            using AxiomC.prems(1) K = KS list  by (simp add: image_Un)
          hence D'': "D'@[Decomp (Fun f S)]  decompsest (ikest A) (assignment_rhsest A) "
            using decompsest.Decomp[OF D'(1) fS_in(2) Ana_fS MS  []] AxiomC.prems(1)
                  intruder_synth.AxiomC[OF fS_in(1)]
            by simp
          moreover {
            fix t' assume "(ikest A set )  ikest (D@[Decomp (Fun f T)]) c t'"
            hence "(ikest A set )  (ikest (D'@[Decomp (Fun f S)]) set ) c t'"
            proof (induction t' rule: intruder_synth_induct)
              case (AxiomC t')
              hence "t'  (ikest A set )  ikest D  t'  ikest [Decomp (Fun f T)]"
                by (simp add: ikest_append)
              thus ?case
              proof
                assume "t'  ikest [Decomp (Fun f T)]"
                hence "t'  ikest [Decomp (Fun f S)] set "
                  using decomp_ik Ana (Fun f T) = (K,M) Ana (Fun f S) = (KS,MS) M = MS list 
                  by simp
                thus ?case
                  using ideduct_synth_mono[
                          OF intruder_synth.AxiomC[of t' "ikest [Decomp (Fun f S)] set "],
                          of "(ikest A set )  (ikest (D'@[Decomp (Fun f S)]) set )"]
                  by (auto simp add: ikest_append)
              next
                assume "t'  (ikest A set )  ikest D"
                hence "(ikest A set )  (ikest D' set ) c t'"
                  by (metis D'(2) intruder_synth.AxiomC)
                hence "(ikest A set )  (ikest D' set )  (ikest [Decomp (Fun f S)] set ) c t'"
                  by (simp add: ideduct_synth_mono)
                thus ?case
                  using ikest_append[of D' "[Decomp (Fun f S)]"]
                        image_Un[of "λx. x  " "ikest D'" "ikest [Decomp (Fun f S)]"]
                  by (simp add: sup_aci(2))
              qed
            qed auto
          }
          ultimately show ?thesis using D'' by auto
        qed
      next
        case (Fun g S) ― ‹Hence Decomp (Fun f T)› can be substituted for Decomp (Fun g S)›
        hence KM: "K = Ks list " "M = Ms list " "set K = set Ks set " "set M = set Ms set "
          using fT_s_in(2) Ana (Fun f T) = (K,M) Ana_s s(2)
                Ana_invar_substD[OF assms(5), of g S]
          by auto
        hence Ms_nonempty: "Ms  []" using M  [] by auto
        { fix t' assume "(ikest A set )  ikest (D@[Decomp (Fun f T)]) c t'"
          hence "(ikest A set )  (ikest (D'@[Decomp (Fun g S)]) set ) c t'" using AxiomC
          proof (induction t' rule: intruder_synth_induct)
            case (AxiomC t')
            hence "t'  ikest A set   t'  ikest D  t'  set M"
              by (simp add: decomp_ik ikest_append)
            thus ?case
            proof (elim disjE)
              assume "t'  ikest D"
              hence *: "(ikest A set )  (ikest D' set ) c t'" using D'(2) by simp
              show ?case by (auto intro: ideduct_synth_mono[OF *] simp add: ikest_append_subst(2))
            next
              assume "t'  set M"
              hence "t'  ikest [Decomp (Fun g S)] set "
                using KM(2) Fun decomp_ik[OF Ana_s] by auto
              thus ?case by (simp add: image_Un ikest_append)
            qed (simp add: ideduct_synth_mono[OF intruder_synth.AxiomC])
          qed auto
        }
        thus ?thesis
          using s Fun Ana_s AxiomC.prems(1) KM(3) fT_s_in
                decompsest.Decomp[OF D'(1) _ _ Ms_nonempty, of g S Ks]
          by (metis AxiomC.hyps image_Un image_eqI intruder_synth.AxiomC)
      qed
    next
      case (ComposeC T f)
      have *: "m. m  set M  (ikest A set )  (ikest D' set ) c m"
        using Ana_fun_subterm[OF Ana (Fun f T) = (K, M)] ComposeC.hyps(3)
        by auto

      have **: "ikest (D@[Decomp (Fun f T)]) = ikest D  set M"
        using decomp_ik[OF Ana (Fun f T) = (K, M)] ikest_append by auto

      { fix t' assume "(ikest A set )  ikest (D@[Decomp (Fun f T)]) c t'"
        hence "(ikest A set )  (ikest D' set ) c t'"
          by (induct rule: intruder_synth_induct) (auto simp add: D'(2) * **)
      }
      thus ?case using D'(1) by auto
    qed
  qed
  thus ?thesis using D(2) assms(1) by (auto simp add: ikest_append_subst(2))
qed

private lemma wfsts'_updatest_nil: assumes "wfsts' 𝒮 𝒜" shows "wfsts' (updatest 𝒮 []) 𝒜"
using assms unfolding wfsts'_def by auto

private lemma wfsts'_updatest_snd:
  assumes "wfsts' 𝒮 𝒜" "send⟨tst#S  𝒮"
  shows "wfsts' (updatest 𝒮 (send⟨tst#S)) (𝒜@[Step (receive⟨tst)])"
unfolding wfsts'_def
proof (intro conjI)
  let ?S = "send⟨tst#S"
  let ?A = "𝒜@[Step (receive⟨tst)]"

  have 𝒮: "S'. S'  updatest 𝒮 ?S  S' = S  S'  𝒮" by auto

  have 1: "S  𝒮. wfst (wfrestrictedvarsest 𝒜) (dualst S)" using assms unfolding wfsts'_def by auto
  moreover have 2: "wfrestrictedvarsest ?A = wfrestrictedvarsest 𝒜  fv t"
    using wfrestrictedvarsest_split(2) by (auto simp add: Un_assoc)
  ultimately have 3: "S  𝒮. wfst (wfrestrictedvarsest ?A) (dualst S)" by (metis wf_vars_mono)

  have 4: "S  𝒮. S'  𝒮. fvst S  bvarsst S' = {}" using assms unfolding wfsts'_def by simp

  have "wfst (wfrestrictedvarsest ?A) (dualst S)" using 1 2 3 assms(2) by auto
  thus "S  updatest 𝒮 ?S. wfst (wfrestrictedvarsest ?A) (dualst S)" by (metis 3 𝒮)

  have "fvst S  bvarsst S = {}"
       "S'  𝒮. fvst S  bvarsst S' = {}"
       "S'  𝒮. fvst S'  bvarsst S = {}"
    using 4 assms(2) unfolding wfsts'_def by force+
  thus "S  updatest 𝒮 ?S. S'  updatest 𝒮 ?S. fvst S  bvarsst S' = {}" by (metis 4 𝒮)

  have "S'  𝒮. fvst ?S  bvarsst S' = {}" "S'  𝒮. fvst S'  bvarsst ?S = {}"
    using assms unfolding wfsts'_def by metis+
  hence 5: "fvest ?A = fvest 𝒜  fv t" "bvarsest ?A = bvarsest 𝒜" "S'  𝒮. fv t  bvarsst S' = {}"
    using to_st_append by fastforce+

  have *: "S  𝒮. fvst S  bvarsest ?A = {}"
    using 5 assms(1) unfolding wfsts'_def by fast
  hence "fvst ?S  bvarsest ?A = {}" using assms(2) by metis
  hence "fvst S  bvarsest ?A = {}" by auto
  thus "S  updatest 𝒮 ?S. fvst S  bvarsest ?A = {}" by (metis * 𝒮)

  have **: "S  𝒮. fvest ?A  bvarsst S = {}"
    using 5 assms(1) unfolding wfsts'_def by fast
  hence "fvest ?A  bvarsst ?S = {}" using assms(2) by metis
  hence "fvest ?A  bvarsst S = {}" by fastforce
  thus "S  updatest 𝒮 ?S. fvest ?A  bvarsst S = {}" by (metis ** 𝒮)
qed

private lemma wfsts'_updatest_rcv:
  assumes "wfsts' 𝒮 𝒜" "receive⟨tst#S  𝒮"
  shows "wfsts' (updatest 𝒮 (receive⟨tst#S)) (𝒜@[Step (send⟨tst)])"
unfolding wfsts'_def
proof (intro conjI)
  let ?S = "receive⟨tst#S"
  let ?A = "𝒜@[Step (send⟨tst)]"

  have 𝒮: "S'. S'  updatest 𝒮 ?S  S' = S  S'  𝒮" by auto

  have 1: "S  𝒮. wfst (wfrestrictedvarsest 𝒜) (dualst S)" using assms unfolding wfsts'_def by auto
  moreover have 2: "wfrestrictedvarsest ?A = wfrestrictedvarsest 𝒜  fv t"
    using wfrestrictedvarsest_split(2) by (auto simp add: Un_assoc)
  ultimately have 3: "S  𝒮. wfst (wfrestrictedvarsest ?A) (dualst S)" by (metis wf_vars_mono)

  have 4: "S  𝒮. S'  𝒮. fvst S  bvarsst S' = {}" using assms unfolding wfsts'_def by simp

  have "wfst (wfrestrictedvarsest ?A) (dualst S)" using 1 2 3 assms(2) by auto
  thus "S  updatest 𝒮 ?S. wfst (wfrestrictedvarsest ?A) (dualst S)" by (metis 3 𝒮)

  have "fvst S  bvarsst S = {}"
       "S'  𝒮. fvst S  bvarsst S' = {}"
       "S'  𝒮. fvst S'  bvarsst S = {}"
    using 4 assms(2) unfolding wfsts'_def by force+
  thus "S  updatest 𝒮 ?S. S'  updatest 𝒮 ?S. fvst S  bvarsst S' = {}" by (metis 4 𝒮)

  have "S'  𝒮. fvst ?S  bvarsst S' = {}" "S'  𝒮. fvst S'  bvarsst ?S = {}"
    using assms unfolding wfsts'_def by metis+
  hence 5: "fvest ?A = fvest 𝒜  fv t" "bvarsest ?A = bvarsest 𝒜" "S'  𝒮. fv t  bvarsst S' = {}"
    using to_st_append by fastforce+

  have *: "S  𝒮. fvst S  bvarsest ?A = {}"
    using 5 assms(1) unfolding wfsts'_def by fast
  hence "fvst ?S  bvarsest ?A = {}" using assms(2) by metis
  hence "fvst S  bvarsest ?A = {}" by auto
  thus "S  updatest 𝒮 ?S. fvst S  bvarsest ?A = {}" by (metis * 𝒮)

  have **: "S  𝒮. fvest ?A  bvarsst S = {}"
    using 5 assms(1) unfolding wfsts'_def by fast
  hence "fvest ?A  bvarsst ?S = {}" using assms(2) by metis
  hence "fvest ?A  bvarsst S = {}" by fastforce
  thus "S  updatest 𝒮 ?S. fvest ?A  bvarsst S = {}" by (metis ** 𝒮)
qed

private lemma wfsts'_updatest_eq:
  assumes "wfsts' 𝒮 𝒜" "a: t  t'st#S  𝒮"
  shows "wfsts' (updatest 𝒮 (a: t  t'st#S)) (𝒜@[Step (a: t  t'st)])"
unfolding wfsts'_def
proof (intro conjI)
  let ?S = "a: t  t'st#S"
  let ?A = "𝒜@[Step (a: t  t'st)]"

  have 𝒮: "S'. S'  updatest 𝒮 ?S  S' = S  S'  𝒮" by auto

  have 1: "S  𝒮. wfst (wfrestrictedvarsest 𝒜) (dualst S)" using assms unfolding wfsts'_def by auto
  moreover have 2:
      "a = Assign  wfrestrictedvarsest ?A = wfrestrictedvarsest 𝒜  fv t  fv t'"
      "a = Check  wfrestrictedvarsest ?A = wfrestrictedvarsest 𝒜"
    using wfrestrictedvarsest_split(2) by (auto simp add: Un_assoc)
  ultimately have 3: "S  𝒮. wfst (wfrestrictedvarsest ?A) (dualst S)"
    by (cases a) (metis wf_vars_mono, metis)

  have 4: "S  𝒮. S'  𝒮. fvst S  bvarsst S' = {}" using assms unfolding wfsts'_def by simp

  have "wfst (wfrestrictedvarsest ?A) (dualst S)" using 1 2 3 assms(2) by (cases a) auto
  thus "S  updatest 𝒮 ?S. wfst (wfrestrictedvarsest ?A) (dualst S)" by (metis 3 𝒮)

  have "fvst S  bvarsst S = {}"
       "S'  𝒮. fvst S  bvarsst S' = {}"
       "S'  𝒮. fvst S'  bvarsst S = {}"
    using 4 assms(2) unfolding wfsts'_def by force+
  thus "S  updatest 𝒮 ?S. S'  updatest 𝒮 ?S. fvst S  bvarsst S' = {}" by (metis 4 𝒮)

  have "S'  𝒮. fvst ?S  bvarsst S' = {}" "S'  𝒮. fvst S'  bvarsst ?S = {}"
    using assms unfolding wfsts'_def by metis+
  hence 5: "fvest ?A = fvest 𝒜  fv t  fv t'" "bvarsest ?A = bvarsest 𝒜"
           "S'  𝒮. fv t  bvarsst S' = {}" "S'  𝒮. fv t'  bvarsst S' = {}"
    using to_st_append by fastforce+

  have *: "S  𝒮. fvst S  bvarsest ?A = {}"
    using 5 assms(1) unfolding wfsts'_def by fast
  hence "fvst ?S  bvarsest ?A = {}" using assms(2) by metis
  hence "fvst S  bvarsest ?A = {}" by auto
  thus "S  updatest 𝒮 ?S. fvst S  bvarsest ?A = {}" by (metis * 𝒮)

  have **: "S  𝒮. fvest ?A  bvarsst S = {}"
    using 5 assms(1) unfolding wfsts'_def by fast
  hence "fvest ?A  bvarsst ?S = {}" using assms(2) by metis
  hence "fvest ?A  bvarsst S = {}" by fastforce
  thus "S  updatest 𝒮 ?S. fvest ?A  bvarsst S = {}" by (metis ** 𝒮)
qed

private lemma wfsts'_updatest_ineq:
  assumes "wfsts' 𝒮 𝒜" "X⟨∨≠: Fst#S  𝒮"
  shows "wfsts' (updatest 𝒮 (X⟨∨≠: Fst#S)) (𝒜@[Step (X⟨∨≠: Fst)])"
unfolding wfsts'_def
proof (intro conjI)
  let ?S = "X⟨∨≠: Fst#S"
  let ?A = "𝒜@[Step (X⟨∨≠: Fst)]"

  have 𝒮: "S'. S'  updatest 𝒮 ?S  S' = S  S'  𝒮" by auto

  have 1: "S  𝒮. wfst (wfrestrictedvarsest 𝒜) (dualst S)" using assms unfolding wfsts'_def by auto
  moreover have 2: "wfrestrictedvarsest ?A = wfrestrictedvarsest 𝒜"
    using wfrestrictedvarsest_split(2) by (auto simp add: Un_assoc)
  ultimately have 3: "S  𝒮. wfst (wfrestrictedvarsest ?A) (dualst S)" by metis

  have 4: "S  𝒮. S'  𝒮. fvst S  bvarsst S' = {}" using assms unfolding wfsts'_def by simp

  have "wfst (wfrestrictedvarsest ?A) (dualst S)" using 1 2 3 assms(2) by auto
  thus "S  updatest 𝒮 ?S. wfst (wfrestrictedvarsest ?A) (dualst S)" by (metis 3 𝒮)

  have "fvst S  bvarsst S = {}"
       "S'  𝒮. fvst S  bvarsst S' = {}"
       "S'  𝒮. fvst S'  bvarsst S = {}"
    using 4 assms(2) unfolding wfsts'_def by force+
  thus "S  updatest 𝒮 ?S. S'  updatest 𝒮 ?S. fvst S  bvarsst S' = {}" by (metis 4 𝒮)

  have "S'  𝒮. fvst ?S  bvarsst S' = {}" "S'  𝒮. fvst S'  bvarsst ?S = {}"
    using assms unfolding wfsts'_def by metis+
  moreover have "fvpairs F - set X  fvst (X⟨∨≠: Fst # S)" by auto
  ultimately have 5:
      "S'  𝒮. (fvpairs F - set X)  bvarsst S' = {}"
      "fvest ?A = fvest 𝒜  (fvpairs F - set X)" "bvarsest ?A = set X  bvarsest 𝒜"
      "S  𝒮. fvst S  set X = {}"
    using to_st_append
    by (blast, force, force, force)

  have *: "S  𝒮. fvst S  bvarsest ?A = {}" using 5(3,4) assms(1) unfolding wfsts'_def by blast
  hence "fvst ?S  bvarsest ?A = {}" using assms(2) by metis
  hence "fvst S  bvarsest ?A = {}" by auto
  thus "S  updatest 𝒮 ?S. fvst S  bvarsest ?A = {}" by (metis * 𝒮)

  have **: "S  𝒮. fvest ?A  bvarsst S = {}"
    using 5(1,2) assms(1) unfolding wfsts'_def by fast
  hence "fvest ?A  bvarsst ?S = {}" using assms(2) by metis
  hence "fvest ?A  bvarsst S = {}" by auto
  thus "S  updatest 𝒮 ?S. fvest ?A  bvarsst S = {}" by (metis ** 𝒮)
qed

private lemma trmsst_updatest_eq:
  assumes "x#S  𝒮"
  shows "(trmsst ` updatest 𝒮 (x#S))  trmsstp x = (trmsst ` 𝒮)" (is "?A = ?B")
proof
  show "?B  ?A"
  proof
    have "trmsstp x  trmsst (x#S)" by auto
    hence "t'. t'  ?B  t'  trmsstp x  t'  ?A" by simp
    moreover {
      fix t' assume t': "t'  ?B" "t'  trmsstp x"
      then obtain S' where S': "t'  trmsst S'" "S'  𝒮" by auto
      hence "S' = x#S  S'  updatest 𝒮 (x#S)" by auto
      moreover {
        assume "S' = x#S"
        hence "t'  trmsst S" using S' t' by simp
        hence "t'  ?A" by auto
      }
      ultimately have "t'  ?A" using t' S' by auto
    }
    ultimately show "t'. t'  ?B  t'  ?A" by metis
  qed

  show "?A  ?B"
  proof
    have "t'. t'  ?A  t'  trmsstp x  trmsstp x  ?B"
      using assms by force+
    moreover {
      fix t' assume t': "t'  ?A" "t'  trmsstp x"
      then obtain S' where "t'  trmsst S'" "S'  updatest 𝒮 (x#S)" by auto
      hence "S' = S  S'  𝒮" by auto
      moreover have "trmsst S  ?B" using assms trmsst_cons[of x S] by blast
      ultimately have "t'  ?B" using t' by fastforce
    }
    ultimately show "t'. t'  ?A  t'  ?B" by blast
  qed
qed

private lemma trmsst_updatest_eq_snd:
  assumes "send⟨tst#S  𝒮" "𝒮' = updatest 𝒮 (send⟨tst#S)" "𝒜' = 𝒜@[Step (receive⟨tst)]"
  shows "((trmsst ` 𝒮))  (trmsest 𝒜) = ((trmsst ` 𝒮'))  (trmsest 𝒜')"
proof -
  have "(trmsest 𝒜') = (trmsest 𝒜)  {t}" "(trmsst ` 𝒮')  {t} = (trmsst ` 𝒮)"
    using to_st_append trmsst_updatest_eq[OF assms(1)] assms(2,3) by auto
  thus ?thesis
    by (metis (no_types, lifting) Un_insert_left Un_insert_right sup_bot.right_neutral)
qed

private lemma trmsst_updatest_eq_rcv:
  assumes "receive⟨tst#S  𝒮" "𝒮' = updatest 𝒮 (receive⟨tst#S)" "𝒜' = 𝒜@[Step (send⟨tst)]"
  shows "((trmsst ` 𝒮))  (trmsest 𝒜) = ((trmsst ` 𝒮'))  (trmsest 𝒜')"
proof -
  have "(trmsest 𝒜') = (trmsest 𝒜)  {t}" "(trmsst ` 𝒮')  {t} = (trmsst ` 𝒮)"
    using to_st_append trmsst_updatest_eq[OF assms(1)] assms(2,3) by auto
  thus ?thesis
    by (metis (no_types, lifting) Un_insert_left Un_insert_right sup_bot.right_neutral)
qed

private lemma trmsst_updatest_eq_eq:
  assumes "a: t  t'st#S  𝒮" "𝒮' = updatest 𝒮 (a: t  t'st#S)" "𝒜' = 𝒜@[Step (a: t  t'st)]"
  shows "((trmsst ` 𝒮))  (trmsest 𝒜) = ((trmsst ` 𝒮'))  (trmsest 𝒜')"
proof -
  have "(trmsest 𝒜') = (trmsest 𝒜)  {t,t'}" "(trmsst ` 𝒮')  {t,t'} = (trmsst ` 𝒮)"
    using to_st_append trmsst_updatest_eq[OF assms(1)] assms(2,3) by auto
  thus ?thesis
    by (metis (no_types, lifting) Un_insert_left Un_insert_right sup_bot.right_neutral)
qed

private lemma trmsst_updatest_eq_ineq:
  assumes "X⟨∨≠: Fst#S  𝒮" "𝒮' = updatest 𝒮 (X⟨∨≠: Fst#S)" "𝒜' = 𝒜@[Step (X⟨∨≠: Fst)]"
  shows "((trmsst ` 𝒮))  (trmsest 𝒜) = ((trmsst ` 𝒮'))  (trmsest 𝒜')"
proof -
  have "(trmsest 𝒜') = (trmsest 𝒜)  trmspairs F" "(trmsst ` 𝒮')  trmspairs F = (trmsst ` 𝒮)"
    using to_st_append trmsst_updatest_eq[OF assms(1)] assms(2,3) by auto
  thus ?thesis by (simp add: Un_commute sup_left_commute)
qed

private lemma ikst_updatest_subset:
  assumes "x#S  𝒮"
  shows "(ikst`dualst ` (updatest 𝒮 (x#S)))  (ikst`dualst ` 𝒮)" (is ?A)
        "(assignment_rhsst ` (updatest 𝒮 (x#S)))  (assignment_rhsst ` 𝒮)" (is ?B)
proof -
  { fix t assume "t  (ikst`dualst ` (updatest 𝒮 (x#S)))"
    then obtain S' where S': "S'  updatest 𝒮 (x#S)" "t  ikst (dualst S')" by auto

    have *: "ikst (dualst S)  ikst (dualst (x#S))"
      using ik_append[of "dualst [x]" "dualst S"] dualst_append[of "[x]" S]
      by auto

    hence "t  (ikst`dualst ` 𝒮)"
    proof (cases "S' = S")
      case True thus ?thesis using * assms S' by auto
    next
      case False thus ?thesis using S' by auto
    qed
  }
  moreover
  { fix t assume "t  (assignment_rhsst ` (updatest 𝒮 (x#S)))"
    then obtain S' where S': "S'  updatest 𝒮 (x#S)" "t  assignment_rhsst S'" by auto

    have "assignment_rhsst S  assignment_rhsst (x#S)"
      using assignment_rhs_append[of "[x]" S] by simp
    hence "t  (assignment_rhsst ` 𝒮)"
      using assms S' by (cases "S' = S") auto
  }
  ultimately show ?A ?B by (metis subsetI)+
qed

private lemma ikst_updatest_subset_snd:
  assumes "send⟨tst#S  𝒮"
          "𝒮' = updatest 𝒮 (send⟨tst#S)"
          "𝒜' = 𝒜@[Step (receive⟨tst)]"
  shows "((ikst ` dualst ` 𝒮'))  (ikest 𝒜') 
         ((ikst ` dualst ` 𝒮))  (ikest 𝒜)" (is ?A)
        "((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜') 
         ((assignment_rhsst ` 𝒮))  (assignment_rhsest 𝒜)" (is ?B)
proof -
  { fix t' assume t'_in: "t'  ((ikst`dualst ` 𝒮'))  (ikest 𝒜')"
    hence "t'  ((ikst`dualst ` 𝒮'))  (ikest 𝒜)  {t}" using assms ikest_append by auto
    moreover have "t  (ikst`dualst ` 𝒮)" using assms(1) by force
    ultimately have "t'  ((ikst`dualst ` 𝒮))  (ikest 𝒜)"
      using ikst_updatest_subset[OF assms(1)] assms(2) by auto
  }
  moreover
  { fix t' assume t'_in: "t'  ((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜')"
    hence "t'  ((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜)"
      using assms assignment_rhsest_append by auto
    hence "t'  ((assignment_rhsst ` 𝒮))  (assignment_rhsest 𝒜)"
      using ikst_updatest_subset[OF assms(1)] assms(2) by auto
  }
  ultimately show ?A ?B by (metis subsetI)+
qed

private lemma ikst_updatest_subset_rcv:
  assumes "receive⟨tst#S  𝒮"
          "𝒮' = updatest 𝒮 (receive⟨tst#S)"
          "𝒜' = 𝒜@[Step (send⟨tst)]"
  shows "((ikst ` dualst ` 𝒮'))  (ikest 𝒜') 
         ((ikst ` dualst ` 𝒮))  (ikest 𝒜)" (is ?A)
        "((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜') 
         ((assignment_rhsst ` 𝒮))  (assignment_rhsest 𝒜)" (is ?B)
proof -
  { fix t' assume t'_in: "t'  ((ikst`dualst ` 𝒮'))  (ikest 𝒜')"
    hence "t'  ((ikst`dualst ` 𝒮'))  (ikest 𝒜)" using assms ikest_append by auto
    hence "t'  ((ikst`dualst ` 𝒮))  (ikest 𝒜)"
      using ikst_updatest_subset[OF assms(1)] assms(2) by auto
  }
  moreover
  { fix t' assume t'_in: "t'  ((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜')"
    hence "t'  ((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜)"
      using assms assignment_rhsest_append by auto
    hence "t'  ((assignment_rhsst ` 𝒮))  (assignment_rhsest 𝒜)"
      using ikst_updatest_subset[OF assms(1)] assms(2) by auto
  }
  ultimately show ?A ?B by (metis subsetI)+
qed

private lemma ikst_updatest_subset_eq:
  assumes "a: t  t'st#S  𝒮"
          "𝒮' = updatest 𝒮 (a: t  t'st#S)"
          "𝒜' = 𝒜@[Step (a: t  t'st)]"
  shows "((ikst ` dualst ` 𝒮'))  (ikest 𝒜') 
         ((ikst ` dualst ` 𝒮))  (ikest 𝒜)" (is ?A)
        "((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜') 
         ((assignment_rhsst ` 𝒮))  (assignment_rhsest 𝒜)" (is ?B)
proof -
  have 1: "t'  ((ikst`dualst ` 𝒮))  (ikest 𝒜)"
    when "t'  ((ikst`dualst ` 𝒮'))  (ikest 𝒜')"
    for t'
  proof -
    have "t'  ((ikst`dualst ` 𝒮'))  (ikest 𝒜)" using that assms ikest_append by auto
    thus ?thesis using ikst_updatest_subset[OF assms(1)] assms(2) by auto
  qed

  have 2: "t''  ((assignment_rhsst ` 𝒮))  (assignment_rhsest 𝒜)"
    when "t''  ((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜')" "a = Assign"
    for t''
  proof -
    have "t''  ((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜)  {t'}"
      using that assms assignment_rhsest_append by auto
    moreover have "t'  (assignment_rhsst ` 𝒮)" using assms(1) that by force
    ultimately show ?thesis using ikst_updatest_subset[OF assms(1)] assms(2) that by auto
  qed

  have 3: "assignment_rhsest 𝒜' = assignment_rhsest 𝒜" (is ?C)
          "((assignment_rhsst ` 𝒮'))  ((assignment_rhsst ` 𝒮))" (is ?D)
    when "a = Check"
  proof -
    show ?C using that assms(2,3) by (simp add: assignment_rhsest_append)
    show ?D using assms(1,2,3) ikst_updatest_subset(2) by auto
  qed

  show ?A using 1 2 by (metis subsetI)
  show ?B using 1 2 3 by (cases a) blast+
qed

private lemma ikst_updatest_subset_ineq:
  assumes "X⟨∨≠: Fst#S  𝒮"
          "𝒮' = updatest 𝒮 (X⟨∨≠: Fst#S)"
          "𝒜' = 𝒜@[Step (X⟨∨≠: Fst)]"
  shows "((ikst`dualst ` 𝒮'))  (ikest 𝒜') 
          ((ikst`dualst ` 𝒮))  (ikest 𝒜)" (is ?A)
        "((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜') 
         ((assignment_rhsst ` 𝒮))  (assignment_rhsest 𝒜)" (is ?B)
proof -
  { fix t' assume t'_in: "t'  ((ikst`dualst ` 𝒮'))  (ikest 𝒜')"
    hence "t'  ((ikst`dualst ` 𝒮'))  (ikest 𝒜)" using assms ikest_append by auto
    hence "t'  ((ikst`dualst ` 𝒮))  (ikest 𝒜)"
      using ikst_updatest_subset[OF assms(1)] assms(2) by auto
  }
  moreover
  { fix t' assume t'_in: "t'  ((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜')"
    hence "t'  ((assignment_rhsst ` 𝒮'))  (assignment_rhsest 𝒜)"
      using assms assignment_rhsest_append by auto
    hence "t'  ((assignment_rhsst ` 𝒮))  (assignment_rhsest 𝒜)"
      using ikst_updatest_subset[OF assms(1)] assms(2) by auto
  }
  ultimately show ?A ?B by (metis subsetI)+
qed


subsubsection ‹Transition Systems Definitions›
inductive pts_symbolic::
  "(('fun,'var) strands × ('fun,'var) strand) 
   (('fun,'var) strands × ('fun,'var) strand)  bool"
(infix "" 50) where
  Nil[simp]:        "[]  𝒮  (𝒮,𝒜)  (updatest 𝒮 [],𝒜)"
| Send[simp]:       "send⟨tst#S  𝒮  (𝒮,𝒜)  (updatest 𝒮 (send⟨tst#S),𝒜@[receive⟨tst])"
| Receive[simp]:    "receive⟨tst#S  𝒮  (𝒮,𝒜)  (updatest 𝒮 (receive⟨tst#S),𝒜@[send⟨tst])"
| Equality[simp]:   "a: t  t'st#S  𝒮  (𝒮,𝒜)  (updatest 𝒮 (a: t  t'st#S),𝒜@[a: t  t'st])"
| Inequality[simp]: "X⟨∨≠: Fst#S  𝒮  (𝒮,𝒜)  (updatest 𝒮 (X⟨∨≠: Fst#S),𝒜@[X⟨∨≠: Fst])"

private inductive pts_symbolic_c::
  "(('fun,'var) strands × ('fun,'var) extstrand) 
   (('fun,'var) strands × ('fun,'var) extstrand)  bool"
(infix "c" 50) where
  Nil[simp]:        "[]  𝒮  (𝒮,𝒜) c (updatest 𝒮 [],𝒜)"
| Send[simp]:       "send⟨tst#S  𝒮  (𝒮,𝒜) c (updatest 𝒮 (send⟨tst#S),𝒜@[Step (receive⟨tst)])"
| Receive[simp]:    "receive⟨tst#S  𝒮  (𝒮,𝒜) c (updatest 𝒮 (receive⟨tst#S),𝒜@[Step (send⟨tst)])"
| Equality[simp]:   "a: t  t'st#S  𝒮  (𝒮,𝒜) c (updatest 𝒮 (a: t  t'st#S),𝒜@[Step (a: t  t'st)])"
| Inequality[simp]: "X⟨∨≠: Fst#S  𝒮  (𝒮,𝒜) c (updatest 𝒮 (X⟨∨≠: Fst#S),𝒜@[Step (X⟨∨≠: Fst)])"
| Decompose[simp]:  "Fun f T  subtermsset (ikest 𝒜  assignment_rhsest 𝒜)
                      (𝒮,𝒜) c (𝒮,𝒜@[Decomp (Fun f T)])"

abbreviation pts_symbolic_rtrancl (infix "*" 50) where "a * b  pts_symbolic** a b"
private abbreviation pts_symbolic_c_rtrancl (infix "c*" 50) where "a c* b  pts_symbolic_c** a b"

lemma pts_symbolic_induct[consumes 1, case_names Nil Send Receive Equality Inequality]:
  assumes "(𝒮,𝒜)  (𝒮',𝒜')"
  and "[]  𝒮; 𝒮' = updatest 𝒮 []; 𝒜' = 𝒜  P"
  and "t S. send⟨tst#S  𝒮; 𝒮' = updatest 𝒮 (send⟨tst#S); 𝒜' = 𝒜@[receive⟨tst]  P"
  and "t S. receive⟨tst#S  𝒮; 𝒮' = updatest 𝒮 (receive⟨tst#S); 𝒜' = 𝒜@[send⟨tst]  P"
  and "a t t' S. a: t  t'st#S  𝒮; 𝒮' = updatest 𝒮 (a: t  t'st#S); 𝒜' = 𝒜@[a: t  t'st]  P"
  and "X F S. X⟨∨≠: Fst#S  𝒮; 𝒮' = updatest 𝒮 (X⟨∨≠: Fst#S); 𝒜' = 𝒜@[X⟨∨≠: Fst]  P"
  shows "P"
apply (rule pts_symbolic.cases[OF assms(1)])
using assms(2,3,4,5,6) by simp_all

private lemma pts_symbolic_c_induct[consumes 1, case_names Nil Send Receive Equality Inequality Decompose]:
  assumes "(𝒮,𝒜) c (𝒮',𝒜')"
  and "[]  𝒮; 𝒮' = updatest 𝒮 []; 𝒜' = 𝒜  P"
  and "t S. send⟨tst#S  𝒮; 𝒮' = updatest 𝒮 (send⟨tst#S); 𝒜' = 𝒜@[Step (receive⟨tst)]  P"
  and "t S. receive⟨tst#S  𝒮; 𝒮' = updatest 𝒮 (receive⟨tst#S); 𝒜' = 𝒜@[Step (send⟨tst)]  P"
  and "a t t' S. a: t  t'st#S  𝒮; 𝒮' = updatest 𝒮 (a: t  t'st#S); 𝒜' = 𝒜@[Step (a: t  t'st)]  P"
  and "X F S. X⟨∨≠: Fst#S  𝒮; 𝒮' = updatest 𝒮 (X⟨∨≠: Fst#S); 𝒜' = 𝒜@[Step (X⟨∨≠: Fst)]  P"
  and "f T. Fun f T  subtermsset (ikest 𝒜  assignment_rhsest 𝒜); 𝒮' = 𝒮; 𝒜' = 𝒜@[Decomp (Fun f T)]  P"
  shows "P"
apply (rule pts_symbolic_c.cases[OF assms(1)])
using assms(2,3,4,5,6,7) by simp_all

private lemma pts_symbolic_c_preserves_wf_prot:
  assumes "(𝒮,𝒜) c* (𝒮',𝒜')" "wfsts' 𝒮 𝒜"
  shows "wfsts' 𝒮' 𝒜'"
using assms
proof (induction rule: rtranclp_induct2)
  case (step 𝒮1 𝒜1 𝒮2 𝒜2)
  from step.hyps(2) step.IH[OF step.prems] show ?case
  proof (induction rule: pts_symbolic_c_induct)
    case Decompose
    hence "fvest 𝒜2 = fvest 𝒜1" "bvarsest 𝒜2 = bvarsest 𝒜1"
      using bvars_decomp ik_assignment_rhs_decomp_fv by metis+
    thus ?case using Decompose unfolding wfsts'_def
      by (metis wf_vars_mono wfrestrictedvarsest_split(2))
  qed (metis wfsts'_updatest_nil, metis wfsts'_updatest_snd,
       metis wfsts'_updatest_rcv, metis wfsts'_updatest_eq,
       metis wfsts'_updatest_ineq)
qed metis

private lemma pts_symbolic_c_preserves_wf_is:
  assumes "(𝒮,𝒜) c* (𝒮',𝒜')" "wfsts' 𝒮 𝒜" "wfst V (to_st 𝒜)"
  shows "wfst V (to_st 𝒜')"
using assms
proof (induction rule: rtranclp_induct2)
  case (step 𝒮1 𝒜1 𝒮2 𝒜2)
  hence "(𝒮, 𝒜) c* (𝒮2, 𝒜2)" by auto
  hence *: "wfsts' 𝒮1 𝒜1" "wfsts' 𝒮2 𝒜2"
    using pts_symbolic_c_preserves_wf_prot[OF _ step.prems(1)] step.hyps(1)
    by auto

  from step.hyps(2) step.IH[OF step.prems] show ?case
  proof (induction rule: pts_symbolic_c_induct)
    case Nil thus ?case by auto
  next
    case (Send t S)
    hence "wfst (wfrestrictedvarsest 𝒜1) (receive⟨tst#(dualst S))"
      using *(1) unfolding wfsts'_def by fastforce
    hence "fv t  wfrestrictedvarsst (to_st 𝒜1)  V"
      using wfrestrictedvarsest_eq_wfrestrictedvarsst by auto
    thus ?case using Send wf_rcv_append''' to_st_append by simp
  next
    case (Receive t) thus ?case using wf_snd_append to_st_append by simp
  next
    case (Equality a t t' S)
    hence "wfst (wfrestrictedvarsest 𝒜1) (a: t  t'st#(dualst S))"
      using *(1) unfolding wfsts'_def by fastforce
    hence "fv t'  wfrestrictedvarsst (to_st 𝒜1)  V" when "a = Assign"
      using wfrestrictedvarsest_eq_wfrestrictedvarsst that by auto
    thus ?case using Equality wf_eq_append''' to_st_append by (cases a) auto
  next
    case (Inequality t t' S) thus ?case using wf_ineq_append'' to_st_append by simp
  next
    case (Decompose f T)
    hence "fv (Fun f T)  wfrestrictedvarsest 𝒜1"
      by (metis fv_subterms_set fv_subset subset_trans
                ikst_assignment_rhsst_wfrestrictedvars_subset)
    hence "varsst (decomp (Fun f T))  wfrestrictedvarsst (to_st 𝒜1)  V"
      using decomp_vars[of "Fun f T"] wfrestrictedvarsest_eq_wfrestrictedvarsst[of 𝒜1] by auto
    thus ?case
      using to_st_append[of 𝒜1 "[Decomp (Fun f T)]"]
            wf_append_suffix[OF Decompose.prems] Decompose.hyps(3)
      by (metis append_Nil2 decomp_vars(1,2) to_st.simps(1,3))
  qed
qed metis

private lemma pts_symbolic_c_preserves_tfrset:
  assumes "(𝒮,𝒜) c* (𝒮',𝒜')"
    and "tfrset (((trmsst ` 𝒮))  (trmsest 𝒜))"
    and "wftrms (((trmsst ` 𝒮))  (trmsest 𝒜))"
  shows "tfrset (((trmsst ` 𝒮'))  (trmsest 𝒜'))  wftrms (((trmsst ` 𝒮'))  (trmsest 𝒜'))"
using assms
proof (induction rule: rtranclp_induct2)
  case (step 𝒮1 𝒜1 𝒮2 𝒜2)
  from step.hyps(2) step.IH[OF step.prems] show ?case
  proof (induction rule: pts_symbolic_c_induct)
    case Nil
    hence "(trmsst ` 𝒮1) = (trmsst ` 𝒮2)" by force
    thus ?case using Nil by metis
  next
    case (Decompose f T)
    obtain t where t: "t  ikest 𝒜1  assignment_rhsest 𝒜1" "Fun f T  t"
      using Decompose.hyps(1) by auto
    have t_wf: "wftrm t"
      using Decompose.prems wf_trm_subterm[of _ t]
            trmsest_ik_assignment_rhsI[OF t(1)]
      unfolding tfrset_def
      by (metis UN_E Un_iff)
    have "t  subtermsset (trmsest 𝒜1)" using trmsest_ik_assignment_rhsI t by auto
    hence "Fun f T  SMP (trmsest 𝒜1)"
      by (metis (no_types) SMP.MP SMP.Subterm UN_E t(2))
    hence "{Fun f T}  SMP (trmsest 𝒜1)" using SMP.Subterm[of "Fun f T"] by auto
    moreover have "trmsest 𝒜2 = insert (Fun f T) (trmsest 𝒜1)"
      using Decompose.hyps(3) by auto
    ultimately have *: "SMP (trmsest 𝒜1) = SMP (trmsest 𝒜2)"
      using SMP_subset_union_eq[of "{Fun f T}"]
      by (simp add: Un_commute)
    hence "SMP (((trmsst ` 𝒮1))  (trmsest 𝒜1)) = SMP (((trmsst ` 𝒮2))  (trmsest 𝒜2))"
      using Decompose.hyps(2) SMP_union by auto
    moreover have "t  trmsest 𝒜1. wftrm t" "wftrm (Fun f T)"
      using Decompose.prems wf_trm_subterm t(2) t_wf unfolding tfrset_def by auto
    hence "t  trmsest 𝒜2. wftrm t" by (metis * SMP.MP SMP_wf_trm)
    hence "t  ((trmsst ` 𝒮2))  (trmsest 𝒜2). wftrm t"
      using Decompose.prems Decompose.hyps(2) unfolding tfrset_def by force
    ultimately show ?thesis using Decompose.prems unfolding tfrset_def by presburger
  qed (metis trmsst_updatest_eq_snd, metis trmsst_updatest_eq_rcv,
       metis trmsst_updatest_eq_eq, metis trmsst_updatest_eq_ineq)
qed metis

private lemma pts_symbolic_c_preserves_tfrstp:
  assumes "(𝒮,𝒜) c* (𝒮',𝒜')" "S  𝒮  {to_st 𝒜}. list_all tfrstp S"
  shows "S  𝒮'  {to_st 𝒜'}. list_all tfrstp S"
using assms
proof (induction rule: rtranclp_induct2)
  case (step 𝒮1 𝒜1 𝒮2 𝒜2)
  from step.hyps(2) step.IH[OF step.prems] show ?case
  proof (induction rule: pts_symbolic_c_induct)
    case Nil
    have 1: "S  {to_st 𝒜2}. list_all tfrstp S" using Nil by simp
    have 2: "𝒮2 = 𝒮1 - {[]}" "S  𝒮1. list_all tfrstp S"  using Nil by simp_all
    have "S  𝒮2. list_all tfrstp S"
    proof
      fix S assume "S  𝒮2"
      hence "S  𝒮1" using 2(1) by simp
      thus "list_all tfrstp S" using 2(2) by simp
    qed
    thus ?case using 1 by auto
  next
    case (Send t S)
    have 1: "S  {to_st 𝒜2}. list_all tfrstp S" using Send by (simp add: to_st_append)
    have 2: "𝒮2 = insert S (𝒮1 - {send⟨tst#S})" "S  𝒮1. list_all tfrstp S"  using Send by simp_all
    have 3: "S  𝒮2. list_all tfrstp S"
    proof
      fix S' assume "S'  𝒮2"
      hence "S'  𝒮1  S' = S" using 2(1) by auto
      moreover have "list_all tfrstp S" using Send.hyps 2(2) by auto
      ultimately show "list_all tfrstp S'" using 2(2) by blast
    qed
    thus ?case using 1 by auto
  next
    case (Receive t S)
    have 1: "S  {to_st 𝒜2}. list_all tfrstp S" using Receive by (simp add: to_st_append)
    have 2: "𝒮2 = insert S (𝒮1 - {receive⟨tst#S})" "S  𝒮1. list_all tfrstp S"
      using Receive by simp_all
    have 3: "S  𝒮2. list_all tfrstp S"
    proof
      fix S' assume "S'  𝒮2"
      hence "S'  𝒮1  S' = S" using 2(1) by auto
      moreover have "list_all tfrstp S" using Receive.hyps 2(2) by auto
      ultimately show "list_all tfrstp S'" using 2(2) by blast
    qed
    show ?case using 1 3 by auto
  next
    case (Equality a t t' S)
    have 1: "to_st 𝒜2 = to_st 𝒜1@[a: t  t'st]" "list_all tfrstp (to_st 𝒜1)"
      using Equality by (simp_all add: to_st_append)
    have 2: "list_all tfrstp [a: t  t'st]" using Equality by fastforce
    have 3: "list_all tfrstp (to_st 𝒜2)"
      using tfr_stp_all_append[of "to_st 𝒜1" "[a: t  t'st]"] 1 2 by metis
    hence 4: "S  {to_st 𝒜2}. list_all tfrstp S" using Equality by simp
    have 5: "𝒮2 = insert S (𝒮1 - {a: t  t'st#S})" "S  𝒮1. list_all tfrstp S"
      using Equality by simp_all
    have 6: "S  𝒮2. list_all tfrstp S"
    proof
      fix S' assume "S'  𝒮2"
      hence "S'  𝒮1  S' = S" using 5(1) by auto
      moreover have "list_all tfrstp S" using Equality.hyps 5(2) by auto
      ultimately show "list_all tfrstp S'" using 5(2) by blast
    qed
    thus ?case using 4 by auto
  next
    case (Inequality X F S)
    have 1: "to_st 𝒜2 = to_st 𝒜1@[X⟨∨≠: Fst]" "list_all tfrstp (to_st 𝒜1)"
      using Inequality by (simp_all add: to_st_append)
    have "list_all tfrstp (X⟨∨≠: Fst#S)" using Inequality(1,4) by blast
    hence 2: "list_all tfrstp [X⟨∨≠: Fst]" by simp
    have 3: "list_all tfrstp (to_st 𝒜2)"
      using tfr_stp_all_append[of "to_st 𝒜1" "[X⟨∨≠: Fst]"] 1 2 by metis
    hence 4: "S  {to_st 𝒜2}. list_all tfrstp S" using Inequality by simp
    have 5: "𝒮2 = insert S (𝒮1 - {X⟨∨≠: Fst#S})" "S  𝒮1. list_all tfrstp S"
      using Inequality by simp_all
    have 6: "S  𝒮2. list_all tfrstp S"
    proof
      fix S' assume "S'  𝒮2"
      hence "S'  𝒮1  S' = S" using 5(1) by auto
      moreover have "list_all tfrstp S" using Inequality.hyps 5(2) by auto
      ultimately show "list_all tfrstp S'" using 5(2) by blast
    qed
    thus ?case using 4 by auto
  next
    case (Decompose f T)
    hence 1: "S  𝒮2. list_all tfrstp S" by blast
    have 2: "list_all tfrstp (to_st 𝒜1)" "list_all tfrstp (to_st [Decomp (Fun f T)])"
      using Decompose.prems decomp_tfrstp by auto
    hence "list_all tfrstp (to_st 𝒜1@to_st [Decomp (Fun f T)])" by auto
    hence "list_all tfrstp (to_st 𝒜2)"
      using Decompose.hyps(3) to_st_append[of 𝒜1 "[Decomp (Fun f T)]"]
      by auto
    thus ?case using 1 by blast
  qed
qed

private lemma pts_symbolic_c_preserves_well_analyzed:
  assumes "(𝒮,𝒜) c* (𝒮',𝒜')" "well_analyzed 𝒜"
  shows "well_analyzed 𝒜'"
using assms
proof (induction rule: rtranclp_induct2)
  case (step 𝒮1 𝒜1 𝒮2 𝒜2)
  from step.hyps(2) step.IH[OF step.prems] show ?case
  proof (induction rule: pts_symbolic_c_induct)
    case Receive thus ?case by (metis well_analyzed_singleton(1) well_analyzed_append)
  next
    case Send thus ?case by (metis well_analyzed_singleton(2) well_analyzed_append)
  next
    case Equality thus ?case by (metis well_analyzed_singleton(3) well_analyzed_append)
  next
    case Inequality thus ?case by (metis well_analyzed_singleton(4) well_analyzed_append)
  next
    case (Decompose f T)
    hence "Fun f T  subtermsset (ikest 𝒜1  assignment_rhsest 𝒜1) - (Var`𝒱)" by auto
    thus ?case by (metis well_analyzed.Decomp Decompose.prems Decompose.hyps(3))
  qed simp
qed metis

private lemma pts_symbolic_c_preserves_Ana_invar_subst:
  assumes "(𝒮,𝒜) c* (𝒮',𝒜')"
    and "Ana_invar_subst (
          ((ikst ` dualst ` 𝒮)  (ikest 𝒜)) 
          ((assignment_rhsst ` 𝒮)  (assignment_rhsest 𝒜)))"
  shows "Ana_invar_subst (
          ((ikst ` dualst ` 𝒮')  (ikest 𝒜')) 
          ((assignment_rhsst ` 𝒮')  (assignment_rhsest 𝒜')))"
using assms
proof (induction rule: rtranclp_induct2)
  case (step 𝒮1 𝒜1 𝒮2 𝒜2)
  from step.hyps(2) step.IH[OF step.prems] show ?case
  proof (induction rule: pts_symbolic_c_induct)
    case Nil
    hence "(ikst ` dualst ` 𝒮1) = (ikst ` dualst ` 𝒮2)"
          "(assignment_rhsst ` 𝒮1) = (assignment_rhsst ` 𝒮2)"
      by force+
    thus ?case using Nil by metis
  next
    case Send show ?case
      using ikst_updatest_subset_snd[OF Send.hyps]
            Ana_invar_subst_subset[OF Send.prems]
      by (metis Un_mono)
  next
    case Receive show ?case
      using ikst_updatest_subset_rcv[OF Receive.hyps]
            Ana_invar_subst_subset[OF Receive.prems]
      by (metis Un_mono)
  next
    case Equality show ?case
      using ikst_updatest_subset_eq[OF Equality.hyps]
            Ana_invar_subst_subset[OF Equality.prems]
      by (metis Un_mono)
  next
    case Inequality show ?case
      using ikst_updatest_subset_ineq[OF Inequality.hyps]
            Ana_invar_subst_subset[OF Inequality.prems]
      by (metis Un_mono)
  next
    case (Decompose f T)
    let ?X = "(assignment_rhsst`𝒮2)  assignment_rhsest 𝒜2"
    let ?Y = "(assignment_rhsst`𝒮1)  assignment_rhsest 𝒜1"
    obtain K M where Ana: "Ana (Fun f T) = (K,M)" by moura
    hence *: "ikest 𝒜2 = ikest 𝒜1  set M" "assignment_rhsest 𝒜2 = assignment_rhsest 𝒜1"
      using ikest_append assignment_rhsest_append decomp_ik
            decomp_assignment_rhs_empty Decompose.hyps(3)
      by auto
    { fix g S assume "Fun g S  subtermsset ((ikst`dualst`𝒮2)  ikest 𝒜2  ?X)"
      hence "Fun g S  subtermsset ((ikst`dualst ` 𝒮1)  ikest 𝒜1  set M  ?X)"
        using * Decompose.hyps(2) by auto
      hence "Fun g S  subtermsset ((ikst`dualst ` 𝒮1))
             Fun g S  subtermsset (ikest 𝒜1)
             Fun g S  subtermsset (set M)
             Fun g S  subtermsset ((assignment_rhsst`𝒮1))
             Fun g S  subtermsset (assignment_rhsest 𝒜1)"
        using Decompose * Ana_fun_subterm[OF Ana] by auto
      moreover have "Fun f T  subtermsset (ikest 𝒜1  assignment_rhsest 𝒜1)"
        using trmsest_ik_subtermsI Decompose.hyps(1) by auto
      hence "subterms (Fun f T)  subtermsset (ikest 𝒜1  assignment_rhsest 𝒜1)"
        by (metis in_subterms_subset_Union)
      hence "subtermsset (set M)  subtermsset (ikest 𝒜1  assignment_rhsest 𝒜1)"
        by (meson Un_upper2 Ana_subterm[OF Ana] subterms_subset_set psubsetE subset_trans)
      ultimately have "Fun g S  subtermsset ((ikst`dualst ` 𝒮1)  ikest 𝒜1  ?Y)"
        by auto
    }
    thus ?case using Decompose unfolding Ana_invar_subst_def by metis
  qed
qed

private lemma pts_symbolic_c_preserves_constr_disj_vars:
  assumes "(𝒮,𝒜) c* (𝒮',𝒜')" "wfsts' 𝒮 𝒜" "fvest 𝒜  bvarsest 𝒜 = {}"
  shows "fvest 𝒜'  bvarsest 𝒜' = {}"
using assms
proof (induction rule: rtranclp_induct2)
  case (step 𝒮1 𝒜1 𝒮2 𝒜2)
  have *: "S. S  𝒮1  fvst S  bvarsest 𝒜1 = {}" "S. S  𝒮1  fvest 𝒜1  bvarsst S = {}"
    using pts_symbolic_c_preserves_wf_prot[OF step.hyps(1) step.prems(1)]
    unfolding wfsts'_def by auto
  from step.hyps(2) step.IH[OF step.prems]
  show ?case
  proof (induction rule: pts_symbolic_c_induct)
    case Nil thus ?case by auto
  next
    case (Send t S)
    hence "fvest 𝒜2 = fvest 𝒜1  fv t" "bvarsest 𝒜2 = bvarsest 𝒜1"
          "fvst (send⟨tst#S) = fv t  fvst S"
      using fvest_append bvarsest_append by simp+
    thus ?case using *(1)[OF Send(1)] Send(4) by auto
  next
    case (Receive t S)
    hence "fvest 𝒜2 = fvest 𝒜1  fv t" "bvarsest 𝒜2 = bvarsest 𝒜1"
          "fvst (receive⟨tst#S) = fv t  fvst S"
      using fvest_append bvarsest_append by simp+
    thus ?case using *(1)[OF Receive(1)] Receive(4) by auto
  next
    case (Equality a t t' S)
    hence "fvest 𝒜2 = fvest 𝒜1  fv t  fv t'" "bvarsest 𝒜2 = bvarsest 𝒜1"
          "fvst (a: t  t'st#S) = fv t  fv t'  fvst S"
      using fvest_append bvarsest_append by fastforce+
    thus ?case using *(1)[OF Equality(1)] Equality(4) by auto
  next
    case (Inequality X F S)
    hence "fvest 𝒜2 = fvest 𝒜1  (fvpairs F - set X)" "bvarsest 𝒜2 = bvarsest 𝒜1  set X"
          "fvst (X⟨∨≠: Fst#S) = (fvpairs F - set X)  fvst S"
      using fvest_append bvarsest_append strand_vars_split(3)[of "[X⟨∨≠: Fst]" S]
      by auto+
    moreover have "fvest 𝒜1  set X = {}" using *(2)[OF Inequality(1)] by auto
    ultimately show ?case using *(1)[OF Inequality(1)] Inequality(4) by auto
  next
    case (Decompose f T)
    thus ?case
      using Decompose(3,4) bvars_decomp ik_assignment_rhs_decomp_fv[OF Decompose(1)] by auto
  qed
qed


subsubsection ‹Theorem: The Typing Result Lifted to the Transition System Level›
private lemma wfsts'_decomp_rm:
  assumes "well_analyzed A" "wfsts' S (decomp_rmest A)" shows "wfsts' S A"
unfolding wfsts'_def
proof (intro conjI)
  show "SS. wfst (wfrestrictedvarsest A) (dualst S)"
    by (metis (no_types) assms(2) wfsts'_def wfrestrictedvarsest_decomp_rmest_subset
                wf_vars_mono le_iff_sup)

  show "SaS. S'S. fvst Sa  bvarsst S' = {}" by (metis assms(2) wfsts'_def)

  show "SS. fvst S  bvarsest A = {}" by (metis assms(2) wfsts'_def bvars_decomp_rm)

  show "SS. fvest A  bvarsst S = {}" by (metis assms wfsts'_def well_analyzed_decomp_rmest_fv)
qed

private lemma decompsest_pts_symbolic_c:
  assumes "D  decompsest (ikest A) (assignment_rhsest A) "
  shows "(S,A) c* (S,A@D)"
using assms(1)
proof (induction D rule: decompsest.induct)
  case (Decomp B f X K T)
  have "subtermsset (ikest A  assignment_rhsest A) 
        subtermsset (ikest (A@B)  assignment_rhsest (A@B))"
    using ikest_append[of A B] assignment_rhsest_append[of A B]
    by auto
  hence "Fun f X  subtermsset (ikest (A@B)  assignment_rhsest (A@B))" using Decomp.hyps by auto
  hence "(S,A@B) c (S,A@B@[Decomp (Fun f X)])"
    using pts_symbolic_c.Decompose[of f X "A@B"]
    by simp
  thus ?case
    using Decomp.IH rtrancl_into_rtrancl
          rtranclp_rtrancl_eq[of pts_symbolic_c "(S,A)" "(S,A@B)"]
    by auto
qed simp

private lemma pts_symbolic_to_pts_symbolic_c:
  assumes "(𝒮,to_st (decomp_rmest 𝒜d)) * (𝒮',𝒜')" "semest_d {}  (to_est 𝒜')" "semest_c {}  𝒜d"
  and wf: "wfsts' 𝒮 (decomp_rmest 𝒜d)" "wfest {} 𝒜d"
  and tar: "Ana_invar_subst (((ikst` dualst` 𝒮)  (ikest 𝒜d))
                             ((assignment_rhsst` 𝒮)  (assignment_rhsest 𝒜d)))"
  and wa: "well_analyzed 𝒜d"
  and: "interpretationsubst "
  shows "𝒜d'. 𝒜' = to_st (decomp_rmest 𝒜d')  (𝒮,𝒜d) c* (𝒮',𝒜d')  semest_c {}  𝒜d'"
using assms(1,2)
proof (induction rule: rtranclp_induct2)
  case refl thus ?case using assms by auto
next
  case (step 𝒮1 𝒜1 𝒮2 𝒜2)
  have "semest_d {}  (to_est 𝒜1)" using step.hyps(2) step.prems
    by (induct rule: pts_symbolic_induct, metis, (metis semest_d_split_left to_est_append)+)
  then obtain 𝒜1d where
      𝒜1d: "𝒜1 = to_st (decomp_rmest 𝒜1d)" "(𝒮, 𝒜d) c* (𝒮1, 𝒜1d)" "semest_c {}  𝒜1d"
    using step.IH by moura

  show ?case using step.hyps(2)
  proof (induction rule: pts_symbolic_induct)
    case Nil
    hence "(𝒮, 𝒜d) c* (𝒮2, 𝒜1d)" using 𝒜1d pts_symbolic_c.Nil[OF Nil.hyps(1), of 𝒜1d] by simp
    thus ?case using 𝒜1d Nil by auto
  next
    case (Send t S)
    hence "semest_c {}  (𝒜1d@[Step (receive⟨tst)])" using semest_c.Receive[OF 𝒜1d(3)] by simp
    moreover have "(𝒮1, 𝒜1d) c (𝒮2, 𝒜1d@[Step (receive⟨tst)])"
      using Send.hyps(2) pts_symbolic_c.Send[OF Send.hyps(1), of 𝒜1d] by simp
    moreover have "to_st (decomp_rmest (𝒜1d@[Step (receive⟨tst)])) = 𝒜2"
      using Send.hyps(3) decomp_rmest_append 𝒜1d(1) by (simp add: to_st_append)
    ultimately show ?case using 𝒜1d(2) by auto
  next
    case (Equality a t t' S)
    hence "t   = t'  "
      using step.prems semest_d_eq_sem_st[of "{}"  "to_est 𝒜2"]
            to_st_append to_est_append to_st_to_est_inv
      by auto
    hence "semest_c {}  (𝒜1d@[Step (a: t  t'st)])" using semest_c.Equality[OF 𝒜1d(3)] by simp
    moreover have "(𝒮1, 𝒜1d) c (𝒮2, 𝒜1d@[Step (a: t  t'st)])"
      using Equality.hyps(2) pts_symbolic_c.Equality[OF Equality.hyps(1), of 𝒜1d] by simp
    moreover have "to_st (decomp_rmest (𝒜1d@[Step (a: t  t'st)])) = 𝒜2"
      using Equality.hyps(3) decomp_rmest_append 𝒜1d(1) by (simp add: to_st_append)
    ultimately show ?case using 𝒜1d(2) by auto
  next
    case (Inequality X F S)
    hence "ineq_model  X F"
      using step.prems semest_d_eq_sem_st[of "{}"  "to_est 𝒜2"]
            to_st_append to_est_append to_st_to_est_inv
      by auto
    hence "semest_c {}  (𝒜1d@[Step (X⟨∨≠: Fst)])" using semest_c.Inequality[OF 𝒜1d(3)] by simp
    moreover have "(𝒮1, 𝒜1d) c (𝒮2, 𝒜1d@[Step (X⟨∨≠: Fst)])"
      using Inequality.hyps(2) pts_symbolic_c.Inequality[OF Inequality.hyps(1), of 𝒜1d] by simp
    moreover have "to_st (decomp_rmest (𝒜1d@[Step (X⟨∨≠: Fst)])) = 𝒜2"
      using Inequality.hyps(3) decomp_rmest_append 𝒜1d(1) by (simp add: to_st_append)
    ultimately show ?case using 𝒜1d(2) by auto
  next
    case (Receive t S)
    hence "ikst 𝒜1 set   t  "
      using step.prems semest_d_eq_sem_st[of "{}"  "to_est 𝒜2"]
            strand_sem_split(4)[of "{}" 𝒜1 "[send⟨tst]" ]
            to_st_append to_est_append to_st_to_est_inv
      by auto
    moreover have "ikst 𝒜1 set   ikest 𝒜1d set " using 𝒜1d(1) decomp_rmest_ik_subset by auto
    ultimately have *: "ikest 𝒜1d set   t  " using ideduct_mono by auto

    have "wfsts' 𝒮 𝒜d" by (rule wfsts'_decomp_rm[OF wa assms(4)])
    hence **: "wfest {} 𝒜1d" by (rule pts_symbolic_c_preserves_wf_is[OF 𝒜1d(2) _ assms(5)])

    have "Ana_invar_subst ((ikst`dualst`𝒮1)  (ikest 𝒜1d) 
                           ((assignment_rhsst`𝒮1)  (assignment_rhsest 𝒜1d)))"
      using tar 𝒜1d(2) pts_symbolic_c_preserves_Ana_invar_subst by metis
    hence "Ana_invar_subst (ikest 𝒜1d)" "Ana_invar_subst (assignment_rhsest 𝒜1d)"
      using Ana_invar_subst_subset by blast+
    moreover have "well_analyzed 𝒜1d"
      using pts_symbolic_c_preserves_well_analyzed[OF 𝒜1d(2) wa] by metis
    ultimately obtain D where D:
        "D  decompsest (ikest 𝒜1d) (assignment_rhsest 𝒜1d) "
        "ikest (𝒜1d@D) set  c t  "
      using decompsest_exist_subst[OF * 𝒜1d(3) ** assms(8)] unfolding Ana_invar_subst_def by auto

    have "(𝒮, 𝒜d) c* (𝒮1, 𝒜1d@D)" using 𝒜1d(2) decompsest_pts_symbolic_c[OF D(1), of 𝒮1] by auto
    hence "(𝒮, 𝒜d) c* (𝒮2, 𝒜1d@D@[Step (send⟨tst)])"
      using Receive(2) pts_symbolic_c.Receive[OF Receive.hyps(1), of "𝒜1d@D"] by auto
    moreover have "𝒜2 = to_st (decomp_rmest (𝒜1d@D@[Step (send⟨tst)]))"
      using Receive.hyps(3) 𝒜1d(1) decompsest_decomp_rmest_empty[OF D(1)]
            decomp_rmest_append to_st_append
      by auto
    moreover have "semest_c {}  (𝒜1d@D@[Step (send⟨tst)])"
      using D(2) semest_c.Send[OF semest_c_decompsest_append[OF 𝒜1d(3) D(1)]] by simp
    ultimately show ?case by auto
  qed
qed

private lemma pts_symbolic_c_to_pts_symbolic:
  assumes "(𝒮,𝒜) c* (𝒮',𝒜')" "semest_c {}  𝒜'"
  shows "(𝒮,to_st (decomp_rmest 𝒜)) * (𝒮',to_st (decomp_rmest 𝒜'))"
        "semest_d {}  (decomp_rmest 𝒜')"
proof -
  show "(𝒮,to_st (decomp_rmest 𝒜)) * (𝒮',to_st (decomp_rmest 𝒜'))" using assms(1)
  proof (induction rule: rtranclp_induct2)
    case (step 𝒮1 𝒜1 𝒮2 𝒜2) show ?case using step.hyps(2,1) step.IH
    proof (induction rule: pts_symbolic_c_induct)
      case Nil thus ?case
        using pts_symbolic.Nil[OF Nil.hyps(1), of "to_st (decomp_rmest 𝒜1)"] by simp
    next
      case (Send t S) thus ?case
        using pts_symbolic.Send[OF Send.hyps(1), of "to_st (decomp_rmest 𝒜1)"]
        by (simp add: decomp_rmest_append to_st_append)
    next
      case (Receive t S) thus ?case
        using pts_symbolic.Receive[OF Receive.hyps(1), of "to_st (decomp_rmest 𝒜1)"]
        by (simp add: decomp_rmest_append to_st_append)
    next
      case (Equality a t t' S) thus ?case
        using pts_symbolic.Equality[OF Equality.hyps(1), of "to_st (decomp_rmest 𝒜1)"]
        by (simp add: decomp_rmest_append to_st_append)
    next
      case (Inequality t t' S) thus ?case
        using pts_symbolic.Inequality[OF Inequality.hyps(1), of "to_st (decomp_rmest 𝒜1)"]
        by (simp add: decomp_rmest_append to_st_append)
    next
      case (Decompose t) thus ?case using decomp_rmest_append by simp
    qed
  qed simp
qed (rule semest_d_decomp_rmest_if_semest_c[OF assms(2)])

private lemma pts_symbolic_to_pts_symbolic_c_from_initial:
  assumes "(𝒮0,[]) * (𝒮,𝒜)" "  𝒜" "wfsts' 𝒮0 []"
  and "Ana_invar_subst ((ikst ` dualst ` 𝒮0)  (assignment_rhsst ` 𝒮0))" "interpretationsubst "
  shows "𝒜d. 𝒜 = to_st (decomp_rmest 𝒜d)  (𝒮0,[]) c* (𝒮,𝒜d)  ( c to_st 𝒜d)"
using assms pts_symbolic_to_pts_symbolic_c[of 𝒮0 "[]" 𝒮 𝒜 ]
      semest_c_eq_sem_st[of "{}" ] semest_d_eq_sem_st[of "{}" ]
      to_st_to_est_inv[of 𝒜] strand_sem_eq_defs
by (auto simp add: constr_sem_c_def constr_sem_d_def simp del: subst_range.simps)

private lemma pts_symbolic_c_to_pts_symbolic_from_initial:
  assumes "(𝒮0,[]) c* (𝒮,𝒜)" " c to_st 𝒜"
  shows "(𝒮0,[]) * (𝒮,to_st (decomp_rmest 𝒜))" "  to_st (decomp_rmest 𝒜)"
using assms pts_symbolic_c_to_pts_symbolic[of 𝒮0 "[]" 𝒮 𝒜 ]
      semest_c_eq_sem_st[of "{}" ] semest_d_eq_sem_st[of "{}" ] strand_sem_eq_defs
by (auto simp add: constr_sem_c_def constr_sem_d_def)

private lemma to_st_trms_wf:
  assumes "wftrms (trmsest A)"
  shows "wftrms (trmsst (to_st A))"
using assms
proof (induction A)
  case (Cons x A)
  hence IH: "t  trmsst (to_st A). wftrm t" by auto
  with Cons show ?case
  proof (cases x)
    case (Decomp t)
    hence "wftrm t" using Cons.prems by auto
    obtain K T where Ana_t: "Ana t = (K,T)" by moura
    hence "trmsst (decomp t)  {t}  set K  set T" using decomp_set_unfold[OF Ana_t] by force
    moreover have "t  set T. wftrm t" using Ana_subterm[OF Ana_t] ‹wftrm t wf_trm_subterm by auto
    ultimately have "t  trmsst (decomp t). wftrm t" using Ana_keys_wf'[OF Ana_t] ‹wftrm t by auto
    thus ?thesis using IH Decomp by auto
  qed auto
qed simp

private lemma to_st_trms_SMP_subset: "trmsst (to_st A)  SMP (trmsest A)"
proof
  fix t assume "t  trmsst (to_st A)" thus "t  SMP (trmsest A)"
  proof (induction A)
    case (Cons x A)
    hence *: "t  trmsst (to_st [x])  trmsst (to_st A)" using to_st_append[of "[x]" A] by auto
    have **: "trmsst (to_st A)  trmsst (to_st (x#A))" "trmsest A  trmsest (x#A)"
      using to_st_append[of "[x]" A] by auto
    show ?case
    proof (cases "t  trmsst (to_st A)")
      case True thus ?thesis using Cons.IH SMP_mono[OF **(2)] by auto
    next
      case False
      hence ***: "t  trmsst (to_st [x])" using * by auto
      thus ?thesis
      proof (cases x)
        case (Decomp t')
        hence ****: "t  trmsst (decomp t')" "t'  trmsest (x#A)" using *** by auto
        obtain K T where Ana_t': "Ana t' = (K,T)" by moura
        hence "t  {t'}  set K  set T" using decomp_set_unfold[OF Ana_t'] ****(1) by force
        moreover
        { assume "t = t'" hence ?thesis using SMP.MP[OF ****(2)] by simp }
        moreover
        { assume "t  set K" hence ?thesis using SMP.Ana[OF SMP.MP[OF ****(2)] Ana_t'] by auto }
        moreover
        { assume "t  set T" "t  t'"
          hence "t  t'" using Ana_subterm[OF Ana_t'] by blast
          hence ?thesis using SMP.Subterm[OF SMP.MP[OF ****(2)]] by auto
        }
        ultimately show ?thesis using Decomp by auto
      qed auto
    qed
  qed simp
qed

private lemma to_st_trms_tfrset:
  assumes "tfrset (trmsest A)"
  shows "tfrset (trmsst (to_st A))"
proof -
  have *: "trmsst (to_st A)  SMP (trmsest A)"
    using to_st_trms_wf to_st_trms_SMP_subset assms unfolding tfrset_def by auto
  have "trmsst (to_st A) = trmsst (to_st A)  trmsest A" by (blast dest!: trmsestD)
  hence "SMP (trmsest A) = SMP (trmsst (to_st A))" using SMP_subset_union_eq[OF *] by auto
  thus ?thesis using * assms unfolding tfrset_def by presburger
qed

theorem wt_attack_if_tfr_attack_pts:
  assumes "wfsts 𝒮0" "tfrset ((trmsst ` 𝒮0))" "wftrms ((trmsst ` 𝒮0))" "S  𝒮0. list_all tfrstp S"
  and "Ana_invar_subst ((ikst ` dualst ` 𝒮0)  (assignment_rhsst ` 𝒮0))"
  and "(𝒮0,[]) * (𝒮,𝒜)" "interpretationsubst " "  𝒜, Var"
  shows "τ. interpretationsubst τ  (τ  𝒜, Var)  wtsubst τ  wftrms (subst_range τ)"
proof -
  have "((trmsst ` 𝒮0))  (trmsest []) = (trmsst ` 𝒮0)" "to_st [] = []" "list_all tfrstp []"
    using assms by simp_all
  hence *: "tfrset (((trmsst ` 𝒮0))  (trmsest []))"
           "wftrms (((trmsst ` 𝒮0))  (trmsest []))"
           "wfsts' 𝒮0 []" "S  𝒮0  {to_st []}. list_all tfrstp S"
    using assms wfsts_wfsts' by (metis, metis, metis, simp)

  obtain 𝒜d where 𝒜d: "𝒜 = to_st (decomp_rmest 𝒜d)" "(𝒮0,[]) c* (𝒮,𝒜d)" " c to_st 𝒜d"
    using pts_symbolic_to_pts_symbolic_c_from_initial assms *(3) by metis
  hence "tfrset ((trmsst ` 𝒮)  (trmsest 𝒜d))" "wftrms ((trmsst ` 𝒮)  (trmsest 𝒜d))"
    using pts_symbolic_c_preserves_tfrset[OF _ *(1,2)] by blast+
  hence "tfrset (trmsest 𝒜d)" "wftrms (trmsest 𝒜d)"
    unfolding tfrset_def by (metis DiffE DiffI SMP_union UnCI, metis UnCI)
  hence "tfrset (trmsst (to_st 𝒜d))" "wftrms (trmsst (to_st 𝒜d))"
    by (metis to_st_trms_tfrset, metis to_st_trms_wf)
  moreover have "wfconstr (to_st 𝒜d) Var"
  proof -
    have "wtsubst Var" "wftrms (subst_range Var)" "subst_domain Var  varsest 𝒜d = {}"
         "range_vars Var  bvarsest 𝒜d = {}"
      by (simp_all add: range_vars_alt_def)
    moreover have "wfest {} 𝒜d"
      using pts_symbolic_c_preserves_wf_is[OF 𝒜d(2) *(3), of "{}"]
      by auto
    moreover have "fvst (to_st 𝒜d)  bvarsest 𝒜d = {}"
      using pts_symbolic_c_preserves_constr_disj_vars[OF 𝒜d(2)] assms(1) wfsts_wfsts'
      by fastforce
    ultimately show ?thesis unfolding wfconstr_def wfsubst_def by simp
  qed
  moreover have "list_all tfrstp (to_st 𝒜d)"
    using pts_symbolic_c_preserves_tfrstp[OF 𝒜d(2) *(4)] by blast
  moreover have "wtsubst Var" "wftrms (subst_range Var)" by simp_all
  ultimately obtain τ whereτ:
      "interpretationsubst τ" "τ c to_st 𝒜d, Var" "wtsubst τ" "wftrms (subst_range τ)"
    using wt_attack_if_tfr_attack[OF assms(7) 𝒜d(3)]
          ‹tfrset (trmsst (to_st 𝒜d)) ‹list_all tfrstp (to_st 𝒜d)
    unfolding tfrst_def by metis
  hence "τ  𝒜, Var" using pts_symbolic_c_to_pts_symbolic_from_initial 𝒜d by metis
  thus ?thesis usingτ(1,3,4) by metis
qed


subsubsection ‹Corollary: The Typing Result on the Level of Constraints›
text ‹There exists well-typed models of satisfiable type-flaw resistant constraints›
corollary wt_attack_if_tfr_attack_d:
  assumes "wfst {} 𝒜" "fvst 𝒜  bvarsst 𝒜 = {}" "tfrst 𝒜" "wftrms (trmsst 𝒜)"
  and "Ana_invar_subst (ikst 𝒜  assignment_rhsst 𝒜)"
  and "interpretationsubst " "  𝒜"
  shows "τ. interpretationsubst τ  (τ  𝒜)  wtsubst τ  wftrms (subst_range τ)"
proof -
  { fix S A have "({S},A) * ({},A@dualst S)"
    proof (induction S arbitrary: A)
      case Nil thus ?case using pts_symbolic.Nil[of "{[]}"] by auto
    next
      case (Cons x S)
      hence "({S}, A@dualst [x]) * ({}, A@dualst (x#S))"
        by (metis dualst_append List.append_assoc List.append_Nil List.append_Cons)
      moreover have "({x#S}, A)  ({S}, A@dualst [x])"
        using pts_symbolic.Send[of _ S "{x#S}"] pts_symbolic.Receive[of _ S "{x#S}"]
              pts_symbolic.Equality[of _ _ _ S "{x#S}"] pts_symbolic.Inequality[of _ _ S "{x#S}"]
        by (cases x) auto
      ultimately show ?case by simp
    qed
  }
  hence 0: "({dualst 𝒜},[]) * ({},𝒜)" using dualst_self_inverse by (metis List.append_Nil)

  have "fvst (dualst 𝒜)  bvarsst (dualst 𝒜) = {}" using assms(2) dualst_fv dualst_bvars by metis+
  hence 1: "wfsts {dualst 𝒜}" using assms(1,2) dualst_self_inverse[of 𝒜] unfolding wfsts_def by auto

  have "(trmsst ` {𝒜}) = trmsst 𝒜" "(trmsst ` {dualst 𝒜}) = trmsst (dualst 𝒜)" by auto
  hence "tfrset ((trmsst ` {𝒜}))" "wftrms ((trmsst ` {𝒜}))"
        "((trmsst ` {𝒜})) = (trmsst ` {dualst 𝒜})"
    using assms(3,4) unfolding tfrst_def
    by (metis, metis, metis dualst_trms_eq)
  hence 2: "tfrset ((trmsst ` {dualst 𝒜}))" and 3: "wftrms ((trmsst ` {dualst 𝒜}))" by metis+

  have 4: "S  {dualst 𝒜}. list_all tfrstp S"
    using dualst_tfrstp assms(3) unfolding tfrst_def by blast

  have "assignment_rhsst 𝒜 = assignment_rhsst (dualst 𝒜)"
    by (induct 𝒜 rule: assignment_rhsst.induct) auto
  hence 5: "Ana_invar_subst ((ikst`dualst`{dualst 𝒜})  (assignment_rhsst`{dualst 𝒜}))"
    using assms(5) dualst_self_inverse[of 𝒜] by auto

  show ?thesis by (rule wt_attack_if_tfr_attack_pts[OF 1 2 3 4 5 0 assms(6,7)])
qed

end

end

end

Theory Stateful_Strands

(*
(C) Copyright Andreas Viktor Hess, DTU, 2018-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Stateful_Strands.thy
    Author:     Andreas Viktor Hess, DTU
*)


section ‹Stateful Strands›
theory Stateful_Strands
imports Strands_and_Constraints
begin

subsection ‹Stateful Constraints›
datatype (funssstp: 'a, varssstp: 'b) stateful_strand_step = 
  Send (the_msg: "('a,'b) term") ("send⟨_" 80)
| Receive (the_msg: "('a,'b) term") ("receive⟨_" 80)
| Equality (the_check: poscheckvariant) (the_lhs: "('a,'b) term") (the_rhs: "('a,'b) term")
    ("_: _  _" [80,80])
| Insert (the_elem_term: "('a,'b) term") (the_set_term: "('a,'b) term") ("insert⟨_,_" 80)
| Delete (the_elem_term: "('a,'b) term") (the_set_term: "('a,'b) term") ("delete⟨_,_" 80)
| InSet (the_check: poscheckvariant) (the_elem_term: "('a,'b) term") (the_set_term: "('a,'b) term")
    ("_: _  _" [80,80])
| NegChecks (bvarssstp: "'b list")
    (the_eqs: "(('a,'b) term × ('a,'b) term) list")
    (the_ins: "(('a,'b) term × ('a,'b) term) list")
    ("_⟨∨≠: _ ∨∉: _" [80,80])
where
  "bvarssstp (Send _) = []"
| "bvarssstp (Receive _) = []"
| "bvarssstp (Equality _ _ _) = []"
| "bvarssstp (Insert _ _) = []"
| "bvarssstp (Delete _ _) = []"
| "bvarssstp (InSet _ _ _) = []"

type_synonym ('a,'b) stateful_strand = "('a,'b) stateful_strand_step list"
type_synonym ('a,'b) dbstatelist = "(('a,'b) term × ('a,'b) term) list"
type_synonym ('a,'b) dbstate = "(('a,'b) term × ('a,'b) term) set"

abbreviation
  "is_Assignment x  (is_Equality x  is_InSet x)  the_check x = Assign"

abbreviation
  "is_Check x  ((is_Equality x  is_InSet x)  the_check x = Check)  is_NegChecks x"

abbreviation
  "is_Update x  is_Insert x  is_Delete x"

abbreviation InSet_select ("select⟨_,_") where "select⟨t,s  InSet Assign t s"
abbreviation InSet_check ("_ in _") where "t in s  InSet Check t s"
abbreviation Equality_assign ("_ := _") where "t := s  Equality Assign t s"
abbreviation Equality_check ("_ == _") where "t == s  Equality Check t s"

abbreviation NegChecks_Inequality1 ("_ != _") where
  "t != s  NegChecks [] [(t,s)] []"

abbreviation NegChecks_Inequality2 ("__ != _") where
  "xt != s  NegChecks [x] [(t,s)] []"

abbreviation NegChecks_Inequality3 ("_,__ != _") where
  "x,yt != s  NegChecks [x,y] [(t,s)] []"

abbreviation NegChecks_Inequality4 ("_,_,__ != _") where
  "x,y,zt != s  NegChecks [x,y,z] [(t,s)] []"

abbreviation NegChecks_NotInSet1 ("_ not in _") where
  "t not in s  NegChecks [] [] [(t,s)]"

abbreviation NegChecks_NotInSet2 ("__ not in _") where
  "xt not in s  NegChecks [x] [] [(t,s)]"

abbreviation NegChecks_NotInSet3 ("_,__ not in _") where
  "x,yt not in s  NegChecks [x,y] [] [(t,s)]"

abbreviation NegChecks_NotInSet4 ("_,_,__ not in _") where
  "x,y,zt not in s  NegChecks [x,y,z] [] [(t,s)]"

fun trmssstp where
  "trmssstp (Send t) = {t}"
| "trmssstp (Receive t) = {t}"
| "trmssstp (Equality _ t t') = {t,t'}"
| "trmssstp (Insert t t') = {t,t'}"
| "trmssstp (Delete t t') = {t,t'}"
| "trmssstp (InSet _ t t') = {t,t'}"
| "trmssstp (NegChecks _ F F') = trmspairs F  trmspairs F'"

definition trmssst where "trmssst S  (trmssstp ` set S)"
declare trmssst_def[simp]

fun trms_listsstp where
  "trms_listsstp (Send t) = [t]"
| "trms_listsstp (Receive t) = [t]"
| "trms_listsstp (Equality _ t t') = [t,t']"
| "trms_listsstp (Insert t t') = [t,t']"
| "trms_listsstp (Delete t t') = [t,t']"
| "trms_listsstp (InSet _ t t') = [t,t']"
| "trms_listsstp (NegChecks _ F F') = concat (map (λ(t,t'). [t,t']) (F@F'))"

definition trms_listsst where "trms_listsst S  remdups (concat (map trms_listsstp S))"

definition iksst where "iksst A  {t. Receive t  set A}"

definition bvarssst::"('a,'b) stateful_strand  'b set" where
  "bvarssst S  (set (map (set  bvarssstp) S))"

fun fvsstp::"('a,'b) stateful_strand_step  'b set" where
  "fvsstp (Send t) = fv t"
| "fvsstp (Receive t) = fv t"
| "fvsstp (Equality _ t t') = fv t  fv t'"
| "fvsstp (Insert t t') = fv t  fv t'"
| "fvsstp (Delete t t') = fv t  fv t'"
| "fvsstp (InSet _ t t') = fv t  fv t'"
| "fvsstp (NegChecks X F F') = fvpairs F  fvpairs F' - set X"

definition fvsst::"('a,'b) stateful_strand  'b set" where
  "fvsst S  (set (map fvsstp S))"

fun fv_listsstp where
  "fv_listsstp (send⟨t) = fv_list t"
| "fv_listsstp (receive⟨t) = fv_list t"
| "fv_listsstp (_: t  s) = fv_list t@fv_list s"
| "fv_listsstp (insert⟨t,s) = fv_list t@fv_list s"
| "fv_listsstp (delete⟨t,s) = fv_list t@fv_list s"
| "fv_listsstp (_: t  s) = fv_list t@fv_list s"
| "fv_listsstp (X⟨∨≠: F ∨∉: F') = filter (λx. x  set X) (fv_listpairs (F@F'))"

definition fv_listsst where
  "fv_listsst S  remdups (concat (map fv_listsstp S))"

declare bvarssst_def[simp]
declare fvsst_def[simp]

definition varssst::"('a,'b) stateful_strand  'b set" where
  "varssst S  (set (map varssstp S))"

abbreviation wfrestrictedvarssstp::"('a,'b) stateful_strand_step  'b set" where
  "wfrestrictedvarssstp x 
    case x of
      NegChecks _ _ _  {}
    | Equality Check _ _  {}
    | InSet Check _ _  {}
    | Delete _ _  {}
    | _  varssstp x"

definition wfrestrictedvarssst::"('a,'b) stateful_strand  'b set" where
  "wfrestrictedvarssst S  (set (map wfrestrictedvarssstp S))"

abbreviation wfvarsoccssstp where
  "wfvarsoccssstp x  
    case x of
      Send t  fv t
    | Equality Assign s t  fv s
    | InSet Assign s t  fv s  fv t
    | _  {}"

definition wfvarsoccssst where
  "wfvarsoccssst S  (set (map wfvarsoccssstp S))"

fun wf'sst::"'b set  ('a,'b) stateful_strand  bool" where
  "wf'sst V [] = True"
| "wf'sst V (Receive t#S) = (fv t  V  wf'sst V S)"
| "wf'sst V (Send t#S) = wf'sst (V  fv t) S"
| "wf'sst V (Equality Assign t t'#S) = (fv t'  V  wf'sst (V  fv t) S)"
| "wf'sst V (Equality Check _ _#S) = wf'sst V S"
| "wf'sst V (Insert t s#S) = (fv t  V  fv s  V  wf'sst V S)"
| "wf'sst V (Delete _ _#S) = wf'sst V S"
| "wf'sst V (InSet Assign t s#S) = wf'sst (V  fv t  fv s) S"
| "wf'sst V (InSet Check _ _#S) = wf'sst V S"
| "wf'sst V (NegChecks _ _ _#S) = wf'sst V S"

abbreviation "wfsst S  wf'sst {} S  fvsst S  bvarssst S = {}"

fun subst_apply_stateful_strand_step::
  "('a,'b) stateful_strand_step  ('a,'b) subst  ('a,'b) stateful_strand_step"
  (infix "sstp" 51) where
  "send⟨t sstp θ = send⟨t  θ"
| "receive⟨t sstp θ = receive⟨t  θ"
| "a: t  s sstp θ = a: (t  θ)  (s  θ)"
| "a: t  s sstp θ = a: (t  θ)  (s  θ)"
| "insert⟨t,s sstp θ = insert⟨t  θ, s  θ"
| "delete⟨t,s sstp θ = delete⟨t  θ, s  θ"
| "X⟨∨≠: F ∨∉: G sstp θ = X⟨∨≠: (F pairs rm_vars (set X) θ) ∨∉: (G pairs rm_vars (set X) θ)"

definition subst_apply_stateful_strand::
  "('a,'b) stateful_strand  ('a,'b) subst  ('a,'b) stateful_strand"
  (infix "sst" 51) where
  "S sst θ  map (λx. x sstp θ) S"

fun dbupdsst::"('f,'v) stateful_strand  ('f,'v) subst  ('f,'v) dbstate  ('f,'v) dbstate"
where
  "dbupdsst [] I D = D"
| "dbupdsst (Insert t s#A) I D = dbupdsst A I (insert ((t,s) p I) D)"
| "dbupdsst (Delete t s#A) I D = dbupdsst A I (D - {((t,s) p I)})"
| "dbupdsst (_#A) I D = dbupdsst A I D"

fun db'sst::"('f,'v) stateful_strand  ('f,'v) subst  ('f,'v) dbstatelist  ('f,'v) dbstatelist"
where
  "db'sst [] I D = D"
| "db'sst (Insert t s#A) I D = db'sst A I (List.insert ((t,s) p I) D)"
| "db'sst (Delete t s#A) I D = db'sst A I (List.removeAll ((t,s) p I) D)"
| "db'sst (_#A) I D = db'sst A I D"

definition dbsst where
  "dbsst S I  db'sst S I []"

fun setopssstp where
  "setopssstp (Insert t s) = {(t,s)}"
| "setopssstp (Delete t s) = {(t,s)}"
| "setopssstp (InSet _ t s) = {(t,s)}"
| "setopssstp (NegChecks _ _ F') = set F'"
| "setopssstp _ = {}"

text ‹The set-operations of a stateful strand›
definition setopssst where
  "setopssst S  (setopssstp ` set S)"

fun setops_listsstp where
  "setops_listsstp (Insert t s) = [(t,s)]"
| "setops_listsstp (Delete t s) = [(t,s)]"
| "setops_listsstp (InSet _ t s) = [(t,s)]"
| "setops_listsstp (NegChecks _ _ F') = F'"
| "setops_listsstp _ = []"

text ‹The set-operations of a stateful strand (list variant)›
definition setops_listsst where
  "setops_listsst S  remdups (concat (map setops_listsstp S))"


subsection ‹Small Lemmata›
lemma trms_listsst_is_trmssst: "trmssst S = set (trms_listsst S)"
unfolding trmsst_def trms_listsst_def
proof (induction S)
  case (Cons x S) thus ?case by (cases x) auto
qed simp

lemma setops_listsst_is_setopssst: "setopssst S = set (setops_listsst S)"
unfolding setopssst_def setops_listsst_def
proof (induction S)
  case (Cons x S) thus ?case by (cases x) auto
qed simp

lemma fv_listsstp_is_fvsstp: "fvsstp a = set (fv_listsstp a)"
proof (cases a)
  case (NegChecks X F G) thus ?thesis
    using fvpairs_append[of F G] fv_listpairs_append[of F G]
          fv_listpairs_is_fvpairs[of "F@G"]
    by auto
qed (simp_all add: fv_listpairs_is_fvpairs fv_list_is_fv)

lemma fv_listsst_is_fvsst: "fvsst S = set (fv_listsst S)"
unfolding fvsst_def fv_listsst_def by (induct S) (simp_all add: fv_listsstp_is_fvsstp)

lemma trmssstp_finite[simp]: "finite (trmssstp x)"
by (cases x) auto

lemma trmssst_finite[simp]: "finite (trmssst S)"
using trmssstp_finite unfolding trmssst_def by (induct S) auto

lemma varssstp_finite[simp]: "finite (varssstp x)"
by (cases x) auto

lemma varssst_finite[simp]: "finite (varssst S)"
using varssstp_finite unfolding varssst_def by (induct S) auto

lemma fvsstp_finite[simp]: "finite (fvsstp x)"
by (cases x) auto

lemma fvsst_finite[simp]: "finite (fvsst S)"
using fvsstp_finite unfolding fvsst_def by (induct S) auto

lemma bvarssstp_finite[simp]: "finite (set (bvarssstp x))"
by (rule finite_set)

lemma bvarssst_finite[simp]: "finite (bvarssst S)"
using bvarssstp_finite unfolding bvarssst_def by (induct S) auto

lemma subst_sst_nil[simp]: "[] sst δ = []"
by (simp add: subst_apply_stateful_strand_def)

lemma dbsst_nil[simp]: "dbsst []  = []"
by (simp add: dbsst_def)

lemma iksst_nil[simp]: "iksst [] = {}"
by (simp add: iksst_def)

lemma iksst_append[simp]: "iksst (A@B) = iksst A  iksst B"
  by (auto simp add: iksst_def)

lemma iksst_subst: "iksst (A sst δ) = iksst A set δ"
proof (induction A)
  case (Cons a A) thus ?case
    by (cases a) (auto simp add: iksst_def subst_apply_stateful_strand_def)
qed simp

lemma dbsst_set_is_dbupdsst: "set (db'sst A I D) = dbupdsst A I (set D)" (is "?A = ?B")
proof
  show "?A  ?B"
  proof
    fix t s show "(t,s)  ?A  (t,s)  ?B" by (induct rule: db'sst.induct) auto
  qed

  show "?B  ?A"
  proof
    fix t s show "(t,s)  ?B  (t,s)  ?A" by (induct arbitrary: D rule: dbupdsst.induct) auto
  qed
qed

lemma dbupdsst_no_upd:
  assumes "a  set A. ¬is_Insert a  ¬is_Delete a"
  shows "dbupdsst A I D = D"
using assms
proof (induction A)
  case (Cons a A) thus ?case by (cases a) auto
qed simp

lemma dbsst_no_upd:
  assumes "a  set A. ¬is_Insert a  ¬is_Delete a"
  shows "db'sst A I D = D"
using assms
proof (induction A)
  case (Cons a A) thus ?case by (cases a) auto
qed simp

lemma dbsst_no_upd_append:
  assumes "b  set B. ¬is_Insert b  ¬is_Delete b"
  shows "db'sst A = db'sst (A@B)"
  using assms
proof (induction A)
  case Nil thus ?case by (simp add: dbsst_no_upd)
next
  case (Cons a A) thus ?case by (cases a) simp_all
qed

lemma dbsst_append:
  "db'sst (A@B) I D = db'sst B I (db'sst A I D)"
proof (induction A arbitrary: D)
  case (Cons a A) thus ?case by (cases a) auto
qed simp

lemma dbsst_in_cases:
  assumes "(t,s)  set (db'sst A I D)"
  shows "(t,s)  set D  (t' s'. insert⟨t',s'  set A  t = t'  I  s = s'  I)"
  using assms
proof (induction A arbitrary: D)
  case (Cons a A) thus ?case by (cases a) fastforce+
qed simp

lemma dbsst_in_cases':
  assumes "(t,s)  set (db'sst A I D)"
    and "(t,s)  set D"
  shows "B C t' s'. A = B@insert⟨t',s'#C  t = t'  I  s = s'  I 
                     (t'' s''. delete⟨t'',s''  set C  t  t''  I  s  s''  I)"
  using assms(1)
proof (induction A rule: List.rev_induct)
  case (snoc a A)
  note * = snoc dbsst_append[of A "[a]" I D]
  thus ?case
  proof (cases a)
    case (Insert t' s')
    thus ?thesis using * by (cases "(t,s)  set (db'sst A I D)") force+
  next
    case (Delete t' s')
    hence **: "t  t'  I  s  s'  I" using * by simp

    have "(t,s)  set (db'sst A I D)" using * Delete by force
    then obtain B C u v where B:
        "A = B@insert⟨u,v#C" "t = u  I" "s = v  I"
        "t' s'. delete⟨t',s'  set C  t  t'  I  s  s'  I"
      using snoc.IH by moura

    have "A@[a] = B@insert⟨u,v#(C@[a])"
         "t' s'. delete⟨t',s'  set (C@[a])  t  t'  I  s  s'  I"
      using B(1,4) Delete ** by auto
    thus ?thesis using B(2,3) by blast
  qed force+
qed (simp add: assms(2))

lemma dbsst_filter:
  "db'sst A I D = db'sst (filter is_Update A) I D"
by (induct A I D rule: db'sst.induct) simp_all

lemma subst_sst_cons: "a#A sst δ = (a sstp δ)#(A sst δ)"
by (simp add: subst_apply_stateful_strand_def)

lemma subst_sst_snoc: "A@[a] sst δ = (A sst δ)@[a sstp δ]"
by (simp add: subst_apply_stateful_strand_def)

lemma subst_sst_append[simp]: "A@B sst δ = (A sst δ)@(B sst δ)"
by (simp add: subst_apply_stateful_strand_def)

lemma sst_vars_append_subset:
  "fvsst A  fvsst (A@B)" "bvarssst A  bvarssst (A@B)"
  "fvsst B  fvsst (A@B)" "bvarssst B  bvarssst (A@B)"
by auto

lemma sst_vars_disj_cons[simp]: "fvsst (a#A)  bvarssst (a#A) = {}  fvsst A  bvarssst A = {}"
unfolding fvsst_def bvarssst_def by auto

lemma fvsst_cons_subset[simp]: "fvsst A  fvsst (a#A)"
by auto

lemma fvsstp_subst_cases[simp]:
  "fvsstp (send⟨t sstp θ) = fv (t  θ)"
  "fvsstp (receive⟨t sstp θ) = fv (t  θ)"
  "fvsstp (c: t  s sstp θ) = fv (t  θ)  fv (s  θ)"
  "fvsstp (insert⟨t,s sstp θ) = fv (t  θ)  fv (s  θ)"
  "fvsstp (delete⟨t,s sstp θ) = fv (t  θ)  fv (s  θ)"
  "fvsstp (c: t  s sstp θ) = fv (t  θ)  fv (s  θ)"
  "fvsstp (X⟨∨≠: F ∨∉: G sstp θ) =
    fvpairs (F pairs rm_vars (set X) θ)  fvpairs (G pairs rm_vars (set X) θ) - set X"
by simp_all

lemma varssstp_cases[simp]:
  "varssstp (send⟨t) = fv t"
  "varssstp (receive⟨t) = fv t"
  "varssstp (c: t  s) = fv t  fv s"
  "varssstp (insert⟨t,s) = fv t  fv s"
  "varssstp (delete⟨t,s) = fv t  fv s"
  "varssstp (c: t  s) = fv t  fv s"
  "varssstp (X⟨∨≠: F ∨∉: G) = fvpairs F  fvpairs G  set X" (is ?A)
  "varssstp (X⟨∨≠: [(t,s)] ∨∉: []) = fv t  fv s  set X" (is ?B)
  "varssstp (X⟨∨≠: [] ∨∉: [(t,s)]) = fv t  fv s  set X" (is ?C)
proof
  show ?A ?B ?C by auto
qed simp_all

lemma varssstp_subst_cases[simp]:
  "varssstp (send⟨t sstp θ) = fv (t  θ)"
  "varssstp (receive⟨t sstp θ) = fv (t  θ)"
  "varssstp (c: t  s sstp θ) = fv (t  θ)  fv (s  θ)"
  "varssstp (insert⟨t,s sstp θ) = fv (t  θ)  fv (s  θ)"
  "varssstp (delete⟨t,s sstp θ) = fv (t  θ)  fv (s  θ)"
  "varssstp (c: t  s sstp θ) = fv (t  θ)  fv (s  θ)"
  "varssstp (X⟨∨≠: F ∨∉: G sstp θ) =
    fvpairs (F pairs rm_vars (set X) θ)  fvpairs (G pairs rm_vars (set X) θ)  set X" (is ?A)
  "varssstp (X⟨∨≠: [(t,s)] ∨∉: [] sstp θ) =
    fv (t  rm_vars (set X) θ)  fv (s  rm_vars (set X) θ)  set X" (is ?B)
  "varssstp (X⟨∨≠: [] ∨∉: [(t,s)] sstp θ) =
    fv (t  rm_vars (set X) θ)  fv (s  rm_vars (set X) θ)  set X" (is ?C)
proof
  show ?A ?B ?C by auto
qed simp_all

lemma bvarssst_cons_subset: "bvarssst A  bvarssst (a#A)"
by auto

lemma bvarssstp_subst: "bvarssstp (a sstp δ) = bvarssstp a"
by (cases a) auto

lemma bvarssst_subst: "bvarssst (A sst δ) = bvarssst A"
using bvarssstp_subst[of _ δ]
by (induct A) (simp_all add: subst_apply_stateful_strand_def)

lemma bvarssstp_set_cases[simp]:
  "set (bvarssstp (send⟨t)) = {}"
  "set (bvarssstp (receive⟨t)) = {}"
  "set (bvarssstp (c: t  s)) = {}"
  "set (bvarssstp (insert⟨t,s)) = {}"
  "set (bvarssstp (delete⟨t,s)) = {}"
  "set (bvarssstp (c: t  s)) = {}"
  "set (bvarssstp (X⟨∨≠: F ∨∉: G)) = set X"
by simp_all

lemma bvarssstp_NegChecks: "¬is_NegChecks a  bvarssstp a = []"
by (cases a) simp_all

lemma bvarssst_NegChecks: "bvarssst A = bvarssst (filter is_NegChecks A)" 
proof (induction A)
  case (Cons a A) thus ?case by (cases a) fastforce+
qed simp

lemma varssst_append[simp]: "varssst (A@B) = varssst A  varssst B"
by (simp add: varssst_def)

lemma varssst_Nil[simp]: "varssst [] = {}"
by (simp add: varssst_def)

lemma varssst_Cons: "varssst (a#A) = varssstp a  varssst A"
by (simp add: varssst_def)

lemma fvsst_Cons: "fvsst (a#A) = fvsstp a  fvsst A"
unfolding fvsst_def by simp

lemma bvarssst_Cons: "bvarssst (a#A) = set (bvarssstp a)  bvarssst A"
unfolding bvarssst_def by auto

lemma varssst_Cons'[simp]:
  "varssst (send⟨t#A) = varssstp (send⟨t)  varssst A"
  "varssst (receive⟨t#A) = varssstp (receive⟨t)  varssst A"
  "varssst (a: t  s#A) = varssstp (a: t  s)  varssst A"
  "varssst (insert⟨t,s#A) = varssstp (insert⟨t,s)  varssst A"
  "varssst (delete⟨t,s#A) = varssstp (delete⟨t,s)  varssst A"
  "varssst (a: t  s#A) = varssstp (a: t  s)  varssst A"
  "varssst (X⟨∨≠: F ∨∉: G#A) = varssstp (X⟨∨≠: F ∨∉: G)  varssst A"
by (simp_all add: varssst_def)

lemma varssstp_is_fvsstp_bvarssstp:
  fixes x::"('a,'b) stateful_strand_step"
  shows "varssstp x = fvsstp x  set (bvarssstp x)"
proof (cases x)
  case (NegChecks X F G) thus ?thesis by (induct F) force+
qed simp_all

lemma varssst_is_fvsst_bvarssst:
  fixes S::"('a,'b) stateful_strand"
  shows "varssst S = fvsst S  bvarssst S"
proof (induction S)
  case (Cons x S) thus ?case
    using varssstp_is_fvsstp_bvarssstp[of x]
    by (auto simp add: varssst_def)
qed simp

lemma varssstp_NegCheck[simp]:
  "varssstp (X⟨∨≠: F ∨∉: G) = set X  fvpairs F  fvpairs G"
by (simp_all add: sup_commute sup_left_commute varssstp_is_fvsstp_bvarssstp)

lemma bvarssstp_NegCheck[simp]:
  "bvarssstp (X⟨∨≠: F ∨∉: G) = X"
  "set (bvarssstp ([]⟨∨≠: F ∨∉: G)) = {}"
by simp_all

lemma fvsstp_NegCheck[simp]:
  "fvsstp (X⟨∨≠: F ∨∉: G) = fvpairs F  fvpairs G - set X"
  "fvsstp ([]⟨∨≠: F ∨∉: G) = fvpairs F  fvpairs G"
  "fvsstp (t != s) = fv t  fv s"
  "fvsstp (t not in s) = fv t  fv s"
by simp_all

lemma fvsst_append[simp]: "fvsst (A@B) = fvsst A  fvsst B"
by simp

lemma bvarssst_append[simp]: "bvarssst (A@B) = bvarssst A  bvarssst B"
by auto

lemma fvsstp_is_subterm_trmssstp:
  assumes "x  fvsstp a"
  shows "Var x  subtermsset (trmssstp a)"
using assms var_is_subterm
proof (cases a)
  case (NegChecks X F F')
  hence "x  fvpairs F  fvpairs F' - set X" using assms by simp
  thus ?thesis using NegChecks var_is_subterm by fastforce
qed force+

lemma fvsst_is_subterm_trmssst: "x  fvsst A  Var x  subtermsset (trmssst A)"
proof (induction A)
  case (Cons a A) thus ?case using fvsstp_is_subterm_trmssstp by (cases "x  fvsst A") auto
qed simp

lemma var_subterm_trmssstp_is_varssstp:
  assumes "Var x  subtermsset (trmssstp a)"
  shows "x  varssstp a"
using assms vars_iff_subtermeq
proof (cases a)
  case (NegChecks X F F')
  hence "Var x  subtermsset (trmspairs F  trmspairs F')" using assms by simp
  thus ?thesis using NegChecks vars_iff_subtermeq by force
qed force+

lemma var_subterm_trmssst_is_varssst: "Var x  subtermsset (trmssst A)  x  varssst A"
proof (induction A)
  case (Cons a A)
  show ?case
  proof (cases "Var x  subtermsset (trmssst A)")
    case True thus ?thesis using Cons.IH by (simp add: varssst_def)
  next
    case False thus ?thesis
      using Cons.prems var_subterm_trmssstp_is_varssstp
      by (fastforce simp add: varssst_def)
  qed
qed simp

lemma var_trmssst_is_varssst: "Var x  trmssst A  x  varssst A"
by (meson var_subterm_trmssst_is_varssst UN_I term.order_refl)

lemma iksst_trmssst_subset: "iksst A  trmssst A"
by (force simp add: iksst_def)

lemma var_subterm_iksst_is_varssst: "Var x  subtermsset (iksst A)  x  varssst A"
using var_subterm_trmssst_is_varssst iksst_trmssst_subset by fast

lemma var_subterm_iksst_is_fvsst:
  assumes "Var x  subtermsset (iksst A)"
  shows "x  fvsst A"
proof -
  obtain t where t: "Receive t  set A" "Var x  t" using assms unfolding iksst_def by moura
  hence "fv t  fvsst A" unfolding fvsst_def by force
  thus ?thesis using t(2) by (meson contra_subsetD subterm_is_var)
qed

lemma fv_iksst_is_fvsst:
  assumes "x  fvset (iksst A)"
  shows "x  fvsst A"
using var_subterm_iksst_is_fvsst assms var_is_subterm by fastforce

lemma fv_trmssst_subset:
  "fvset (trmssst S)  varssst S"
  "fvsst S  fvset (trmssst S)"
proof (induction S)
  case (Cons x S)
  have *: "fvset (trmssst (x#S)) = fvset (trmssstp x)  fvset (trmssst S)"
          "fvsst (x#S) = fvsstp x  fvsst S" "varssst (x#S) = varssstp x  varssst S"
    unfolding trmssst_def fvsst_def varssst_def
    by auto

  { case 1
    show ?case using Cons.IH(1)
    proof (cases x)
      case (NegChecks X F G)
      hence "trmssstp x = trmspairs F  trmspairs G"
            "varssstp x = fvpairs F  fvpairs G  set X"
        by (simp, meson varssstp_cases(7))
      hence "fvset (trmssstp x)  varssstp x"
        using fv_trmspairs_is_fvpairs[of F] fv_trmspairs_is_fvpairs[of G]
        by auto
      thus ?thesis
        using Cons.IH(1) *(1,3)
        by blast
    qed auto
  }

  { case 2
    show ?case using Cons.IH(2)
    proof (cases x)
      case (NegChecks X F G)
      hence "trmssstp x = trmspairs F  trmspairs G"
            "fvsstp x = (fvpairs F  fvpairs G) - set X"
        by auto
      hence "fvsstp x  fvset (trmssstp x)"
        using fv_trmspairs_is_fvpairs[of F] fv_trmspairs_is_fvpairs[of G]
        by auto
      thus ?thesis
        using Cons.IH(2) *(1,2)
        by blast
    qed auto
  }
qed simp_all

lemma fv_ik_subset_fv_sst'[simp]: "fvset (iksst S)  fvsst S"
unfolding iksst_def by (induct S) auto

lemma fv_ik_subset_vars_sst'[simp]: "fvset (iksst S)  varssst S"
using fv_ik_subset_fv_sst' fv_trmssst_subset by fast

lemma iksst_var_is_fv: "Var x  subtermsset (iksst A)  x  fvsst A"
by (meson fv_ik_subset_fv_sst'[of A] fv_subset_subterms subsetCE term.set_intros(3))

lemma varssstp_subst_cases':
  assumes x: "x  varssstp (s sstp θ)"
  shows "x  varssstp s  x  fvset (θ ` varssstp s)"
using x vars_term_subst[of _ θ] varssstp_cases(1,2,3,4,5,6) varssstp_subst_cases(1,2)[of _ θ]
      varssstp_subst_cases(3,6)[of _ _ _ θ] varssstp_subst_cases(4,5)[of _ _ θ]
proof (cases s)
  case (NegChecks X F G)
  let ?θ' = "rm_vars (set X) θ"
  have "x  fvpairs (F pairs ?θ')  x  fvpairs (G pairs ?θ')  x  set X"
    using varssstp_subst_cases(7)[of X F G θ] x NegChecks by simp
  hence "x  fvset (?θ' ` fvpairs F)  x  fvset (?θ' ` fvpairs G)  x  set X"
    using fvpairs_subst[of _ ?θ'] by blast
  hence "x  fvset (θ ` fvpairs F)  x  fvset (θ ` fvpairs G)  x  set X"
    using rm_vars_fvset_subst by fast
  thus ?thesis
    using NegChecks varssstp_cases(7)[of X F G]
    by auto
qed simp_all

lemma varssst_subst_cases:
  assumes "x  varssst (S sst θ)"
  shows "x  varssst S  x  fvset (θ ` varssst S)"
  using assms
proof (induction S)
  case (Cons s S) thus ?case
  proof (cases "x  varssst (S sst θ)")
    case False
    note * = subst_sst_cons[of s S θ] varssst_Cons[of "s sstp θ" "S sst θ"] varssst_Cons[of s S]
    have **: "x  varssstp (s sstp θ)" using Cons.prems False * by simp
    show ?thesis using varssstp_subst_cases'[OF **] * by auto
  qed (auto simp add: varssst_def)
qed simp

lemma subset_subst_pairs_diff_exists:
  fixes ::"('a,'b) subst" and D D'::"('a,'b) dbstate"
  shows "Di. Di  D  Di pset  = (D pset ) - D'"
by (metis (no_types, lifting) Diff_subset subset_image_iff)

lemma subset_subst_pairs_diff_exists':
  fixes ::"('a,'b) subst" and D::"('a,'b) dbstate"
  assumes "finite D"
  shows "Di. Di  D  Di pset   {d p }  d p   (D - Di) pset "
using assms
proof (induction D rule: finite_induct)
  case (insert d' D)
  then obtain Di where IH: "Di  D" "Di pset   {d p }" "d p   (D - Di) pset " by moura
  show ?case
  proof (cases "d' p  = d p ")
    case True
    hence "insert d' Di  insert d' D" "insert d' Di pset   {d p }"
          "d p   (insert d' D - insert d' Di) pset " 
      using IH by auto
    thus ?thesis by metis
  next
    case False
    hence "Di  insert d' D" "Di pset   {d p }"
          "d p   (insert d' D - Di) pset " 
      using IH by auto
    thus ?thesis by metis
  qed
qed simp

lemma stateful_strand_step_subst_inI[intro]:
  "send⟨t  set A  send⟨t  θ  set (A sst θ)"
  "receive⟨t  set A  receive⟨t  θ  set (A sst θ)"
  "c: t  s  set A  c: (t  θ)  (s  θ)  set (A sst θ)"
  "insert⟨t, s  set A  insert⟨t  θ, s  θ  set (A sst θ)"
  "delete⟨t, s  set A  delete⟨t  θ, s  θ  set (A sst θ)"
  "c: t  s  set A  c: (t  θ)  (s  θ)  set (A sst θ)"
  "X⟨∨≠: F ∨∉: G  set A 
     X⟨∨≠: (F pairs rm_vars (set X) θ) ∨∉: (G pairs rm_vars (set X) θ)  set (A sst θ)"
  "t != s  set A  t  θ != s  θ  set (A sst θ)"
  "t not in s  set A  t  θ not in s  θ  set (A sst θ)"
proof (induction A)
  case (Cons a A)
  note * = subst_sst_cons[of a A θ]
  { case 1 thus ?case using Cons.IH(1) * by (cases a) auto }
  { case 2 thus ?case using Cons.IH(2) * by (cases a) auto }
  { case 3 thus ?case using Cons.IH(3) * by (cases a) auto }
  { case 4 thus ?case using Cons.IH(4) * by (cases a) auto }
  { case 5 thus ?case using Cons.IH(5) * by (cases a) auto }
  { case 6 thus ?case using Cons.IH(6) * by (cases a) auto }
  { case 7 thus ?case using Cons.IH(7) * by (cases a) auto }
  { case 8 thus ?case using Cons.IH(8) * by (cases a) auto }
  { case 9 thus ?case using Cons.IH(9) * by (cases a) auto }
qed simp_all

lemma stateful_strand_step_cases_subst:
  "is_Send a = is_Send (a sstp θ)"
  "is_Receive a = is_Receive (a sstp θ)"
  "is_Equality a = is_Equality (a sstp θ)"
  "is_Insert a = is_Insert (a sstp θ)"
  "is_Delete a = is_Delete (a sstp θ)"
  "is_InSet a = is_InSet (a sstp θ)"
  "is_NegChecks a = is_NegChecks (a sstp θ)"
  "is_Assignment a = is_Assignment (a sstp θ)"
  "is_Check a = is_Check (a sstp θ)"
  "is_Update a = is_Update (a sstp θ)"
by (cases a; simp_all)+

lemma stateful_strand_step_subst_inv_cases:
  "send⟨t  set (S sst σ)  t'. t = t'  σ  send⟨t'  set S"
  "receive⟨t  set (S sst σ)  t'. t = t'  σ  receive⟨t'  set S"
  "c: t  s  set (S sst σ)  t' s'. t = t'  σ  s = s'  σ  c: t'  s'  set S"
  "insert⟨t,s  set (S sst σ)  t' s'. t = t'  σ  s = s'  σ  insert⟨t',s'  set S"
  "delete⟨t,s  set (S sst σ)  t' s'. t = t'  σ  s = s'  σ  delete⟨t',s'  set S"
  "c: t  s  set (S sst σ)  t' s'. t = t'  σ  s = s'  σ  c: t'  s'  set S"
  "X⟨∨≠: F ∨∉: G  set (S sst σ) 
    F' G'. F = F' pairs rm_vars (set X) σ  G = G' pairs rm_vars (set X) σ 
            X⟨∨≠: F' ∨∉: G'  set S"
proof (induction S)
  case (Cons a S)
  have *: "x  set (S sst σ)"
    when "x  set (a#S sst σ)" "x  a sstp σ" for x
    using that by (simp add: subst_apply_stateful_strand_def)

  { case 1 thus ?case using Cons.IH(1)[OF *] by (cases a) auto }
  { case 2 thus ?case using Cons.IH(2)[OF *] by (cases a) auto }
  { case 3 thus ?case using Cons.IH(3)[OF *] by (cases a) auto }
  { case 4 thus ?case using Cons.IH(4)[OF *] by (cases a) auto }
  { case 5 thus ?case using Cons.IH(5)[OF *] by (cases a) auto }
  { case 6 thus ?case using Cons.IH(6)[OF *] by (cases a) auto }
  { case 7 thus ?case using Cons.IH(7)[OF *] by (cases a) auto }
qed simp_all

lemma stateful_strand_step_fv_subset_cases:
  "send⟨t  set S  fv t  fvsst S"
  "receive⟨t  set S  fv t  fvsst S"
  "c: t  s  set S  fv t  fv s  fvsst S"
  "insert⟨t,s  set S  fv t  fv s  fvsst S"
  "delete⟨t,s  set S  fv t  fv s  fvsst S"
  "c: t  s  set S  fv t  fv s  fvsst S"
  "X⟨∨≠: F ∨∉: G  set S  fvpairs F  fvpairs G - set X  fvsst S"
proof (induction S)
  case (Cons a S)
  { case 1 thus ?case using Cons.IH(1) by auto }
  { case 2 thus ?case using Cons.IH(2) by auto }
  { case 3 thus ?case using Cons.IH(3) by auto }
  { case 4 thus ?case using Cons.IH(4) by auto }
  { case 5 thus ?case using Cons.IH(5) by auto }
  { case 6 thus ?case using Cons.IH(6) by auto }
  { case 7 thus ?case using Cons.IH(7) by fastforce }
qed simp_all

lemma trmssst_nil[simp]:
  "trmssst [] = {}"
unfolding trmssst_def by simp

lemma trmssst_mono:
  "set M  set N  trmssst M  trmssst N"
by auto

lemma trmssst_in:
  assumes "t  trmssst S"
  shows "a  set S. t  trmssstp a"
using assms unfolding trmssst_def by simp

lemma trmssst_cons: "trmssst (a#A) = trmssstp a  trmssst A"
unfolding trmssst_def by force

lemma trmssst_append[simp]: "trmssst (A@B) = trmssst A  trmssst B"
unfolding trmssst_def by force

lemma trmssstp_subst:
  assumes "set (bvarssstp a)  subst_domain θ = {}"
  shows "trmssstp (a sstp θ) = trmssstp a set θ"
proof (cases a)
  case (NegChecks X F G)
  hence "rm_vars (set X) θ = θ" using assms rm_vars_apply'[of θ "set X"] by auto
  hence "trmssstp (a sstp θ) = trmspairs (F pairs θ)  trmspairs (G pairs θ)"
        "trmssstp a set θ = (trmspairs F set θ)  (trmspairs G set θ)"
    using NegChecks image_Un by simp_all
  thus ?thesis by (metis trmspairs_subst)
qed simp_all

lemma trmssstp_subst':
  assumes "¬is_NegChecks a"
  shows "trmssstp (a sstp θ) = trmssstp a set θ"
using assms by (cases a) simp_all

lemma trmssstp_subst'':
  fixes t::"('a,'b) term" and δ::"('a,'b) subst"
  assumes "t  trmssstp (b sstp δ)"
  shows "s  trmssstp b. t = s  rm_vars (set (bvarssstp b)) δ"
proof (cases "is_NegChecks b")
  case True
  then obtain X F G where *: "b = NegChecks X F G" by (cases b) moura+
  thus ?thesis using assms trmspairs_subst[of _ "rm_vars (set X) δ"] by auto
next
  case False
  hence "trmssstp (b sstp δ) = trmssstp b set rm_vars (set (bvarssstp b)) δ"
    using trmssstp_subst' bvarssstp_NegChecks
    by fastforce
  thus ?thesis using assms by fast
qed

lemma trmssstp_subst''':
  fixes t::"('a,'b) term" and δ θ::"('a,'b) subst"
  assumes "t  trmssstp (b sstp δ) set θ"
  shows "s  trmssstp b. t = s  rm_vars (set (bvarssstp b)) δ s θ"
proof -
  obtain s where s: "s  trmssstp (b sstp δ)" "t = s  θ" using assms by moura
  show ?thesis using trmssstp_subst''[OF s(1)] s(2) by auto
qed

lemma trmssst_subst:
  assumes "bvarssst S  subst_domain θ = {}"
  shows "trmssst (S sst θ) = trmssst S set θ"
using assms
proof (induction S)
  case (Cons a S)
  hence IH: "trmssst (S sst θ) = trmssst S set θ" and *: "set (bvarssstp a)  subst_domain θ = {}"
    by auto
  show ?case using trmssstp_subst[OF *] IH by (auto simp add: subst_apply_stateful_strand_def)
qed simp

lemma trmssst_subst_cons:
  "trmssst (a#A sst δ) = trmssstp (a sstp δ)  trmssst (A sst δ)"
using subst_sst_cons[of a A δ] trmssst_cons[of a A] trmssst_append by simp

lemma (in intruder_model) wftrms_trmssstp_subst:
  assumes "wftrms (trmssstp a set δ)"
  shows "wftrms (trmssstp (a sstp δ))"
  using assms
proof (cases a)
  case (NegChecks X F G)
  hence *: "trmssstp (a sstp δ) =
              (trmspairs (F pairs rm_vars (set X) δ))  (trmspairs (G pairs rm_vars (set X) δ))"
    by simp

  have "trmssstp a set δ = (trmspairs F set δ)  (trmspairs G set δ)"
    using NegChecks image_Un by simp
  hence "wftrms (trmspairs F set δ)" "wftrms (trmspairs G set δ)" using * assms by auto
  hence "wftrms (trmspairs F set rm_vars (set X) δ)"
        "wftrms (trmspairs G set rm_vars (set X) δ)"
    using wf_trms_subst_rm_vars[of δ "trmspairs F" "set X"]
          wf_trms_subst_rm_vars[of δ "trmspairs G" "set X"]
    by fast+
  thus ?thesis
    using * trmspairs_subst[of _ "rm_vars (set X) δ"]
    by auto
qed auto

lemma trmssst_fv_varssst_subset: "t  trmssst A  fv t  varssst A" 
proof (induction A)
  case (Cons a A) thus ?case by (cases a) auto
qed simp

lemma trmssst_fv_subst_subset:
  assumes "t  trmssst S" "subst_domain θ  bvarssst S = {}"
  shows "fv (t  θ)  varssst (S sst θ)"
using assms
proof (induction S)
  case (Cons s S) show ?case
  proof (cases "t  trmssst S")
    case True
    hence "fv (t  θ)  varssst (S sst θ)" using Cons.IH Cons.prems by auto
    thus ?thesis using subst_sst_cons[of s S θ] unfolding varssst_def by auto
  next
    case False
    hence *: "t  trmssstp s" "subst_domain θ  set (bvarssstp s) = {}" using Cons.prems by auto
    hence "fv (t  θ)  varssstp (s sstp θ)"
    proof (cases s)
      case (NegChecks X F G)
      hence **: "t  trmspairs F  t  trmspairs G" using *(1) by auto
      have ***: "rm_vars (set X) θ = θ" using *(2) NegChecks rm_vars_apply' by auto
      have "fv (t  θ)  fvpairs (F pairs rm_vars (set X) θ)  fvpairs (G pairs rm_vars (set X) θ)"
        using ** *** trmspairs_fv_subst_subset[of t _ θ] by auto
      thus ?thesis using *(2) using NegChecks varssstp_subst_cases(7)[of X F G θ] by blast
    qed auto
    thus ?thesis using subst_sst_cons[of s S θ] unfolding varssst_def by auto
  qed
qed simp

lemma trmssst_fv_subst_subset':
  assumes "t  subtermsset (trmssst S)" "fv t  bvarssst S = {}" "fv (t  θ)  bvarssst S = {}"
  shows "fv (t  θ)  fvsst (S sst θ)"
using assms
proof (induction S)
  case (Cons s S) show ?case
  proof (cases "t  subtermsset (trmssst S)")
    case True
    hence "fv (t  θ)  fvsst (S sst θ)" using Cons.IH Cons.prems by auto
    thus ?thesis using subst_sst_cons[of s S θ] unfolding varssst_def by auto
  next
    case False
    hence 0: "t  subtermsset (trmssstp s)" "fv t  set (bvarssstp s) = {}"
             "fv (t  θ)  set (bvarssstp s) = {}"
      using Cons.prems by auto

    note 1 = UN_Un UN_insert fvset.simps subst_apply_fv_subset subst_apply_fv_unfold
             subst_apply_term_empty sup_bot.comm_neutral fv_subterms_set fv_subset[OF 0(1)]

    note 2 = subst_apply_fv_union

    have "fv (t  θ)  fvsstp (s sstp θ)"
    proof (cases s)
      case (NegChecks X F G)
      hence 3: "t  subtermsset (trmspairs F)  t  subtermsset (trmspairs G)" using 0(1) by auto
      have "t  rm_vars (set X) θ = t  θ" using 0(2) NegChecks rm_vars_ident[of t] by auto
      hence "fv (t  θ)  fvpairs (F pairs rm_vars (set X) θ)  fvpairs (G pairs rm_vars (set X) θ)"
        using 3 trmspairs_fv_subst_subset'[of t _ "rm_vars (set X) θ"] by fastforce
      thus ?thesis using 0(2,3) NegChecks fvsstp_subst_cases(7)[of X F G θ] by auto
    qed (metis (no_types, lifting) 1 trmssstp.simps(1) fvsstp_subst_cases(1),
         metis (no_types, lifting) 1 trmssstp.simps(2) fvsstp_subst_cases(2),
         metis (no_types, lifting) 1 2 trmssstp.simps(3) fvsstp_subst_cases(3),
         metis (no_types, lifting) 1 2 trmssstp.simps(4) fvsstp_subst_cases(4),
         metis (no_types, lifting) 1 2 trmssstp.simps(5) fvsstp_subst_cases(5),
         metis (no_types, lifting) 1 2 trmssstp.simps(6) fvsstp_subst_cases(6))
    thus ?thesis using subst_sst_cons[of s S θ] unfolding fvsst_def by auto
  qed
qed simp

lemma trmssstp_funs_term_cases:
  assumes "t  trmssstp (s sstp θ)" "f  funs_term t"
  shows "(u  trmssstp s. f  funs_term u)  (x  fvsstp s. f  funs_term (θ x))"
  using assms
proof (cases s)
  case (NegChecks X F G)
  hence "t  trmspairs (F pairs rm_vars (set X) θ)  t  trmspairs (G pairs rm_vars (set X) θ)"
    using assms(1) by auto
  hence "(utrmspairs F. f  funs_term u)  (xfvpairs F. f  funs_term (rm_vars (set X) θ x)) 
         (utrmspairs G. f  funs_term u)  (xfvpairs G. f  funs_term (rm_vars (set X) θ x))"
    using trmspairs_funs_term_cases[OF _ assms(2), of _ "rm_vars (set X) θ"] by meson
  hence "(u  trmspairs F  trmspairs G. f  funs_term u) 
         (x  fvpairs F  fvpairs G. f  funs_term (rm_vars (set X) θ x))"
    by blast
  thus ?thesis
  proof
    assume "x  fvpairs F  fvpairs G. f  funs_term (rm_vars (set X) θ x)"
    then obtain x where x: "x  fvpairs F  fvpairs G" "f  funs_term (rm_vars (set X) θ x)"
      by auto
    hence "x  set X" "rm_vars (set X) θ x = θ x" by auto
    thus ?thesis using x by (auto simp add: assms NegChecks)
  qed (auto simp add: assms NegChecks)
qed (use assms funs_term_subst[of _ θ] in auto)

lemma trmssst_funs_term_cases:
  assumes "t  trmssst (S sst θ)" "f  funs_term t"
  shows "(u  trmssst S. f  funs_term u)  (x  fvsst S. f  funs_term (θ x))"
using assms(1)
proof (induction S)
  case (Cons s S) thus ?case
  proof (cases "t  trmssst (S sst θ)")
    case False
    hence "t  trmssstp (s sstp θ)" using Cons.prems(1) subst_sst_cons[of s S θ] trmssst_cons by auto
    thus ?thesis using trmssstp_funs_term_cases[OF _ assms(2)] by fastforce
  qed auto
qed simp

lemma fvsst_is_subterm_trmssst_subst:
  assumes "x  fvsst T"
    and "bvarssst T  subst_domain θ = {}"
  shows "θ x  subtermsset (trmssst (T sst θ))"
using trmssst_subst[OF assms(2)] subterms_subst_subset'[of θ "trmssst T"]
      fvsst_is_subterm_trmssst[OF assms(1)]
by (metis (no_types, lifting) image_iff subset_iff subst_apply_term.simps(1))

lemma fvsst_subst_fv_subset:
  assumes "x  fvsst S" "x  bvarssst S" "fv (θ x)  bvarssst S = {}"
  shows "fv (θ x)  fvsst (S sst θ)"
using assms
proof (induction S)
  case (Cons a S)
  note 1 = fv_subst_subset[of _ _ θ]
  note 2 = subst_apply_fv_union subst_apply_fv_unfold[of _ θ] fv_subset image_eqI
  note 3 = fvsstp_subst_cases
  note 4 = fvsstp.simps
  from Cons show ?case
  proof (cases "x  fvsst S")
    case False
    hence 5: "x  fvsstp a" " fv (θ x)  set (bvarssstp a) = {}" "x  set (bvarssstp a)"
      using Cons.prems by auto
    hence "fv (θ x)  fvsstp (a sstp θ)"
    proof (cases a)
      case (NegChecks X F G)
      let  = "rm_vars (set X) θ"
      have *: "x  fvpairs F  fvpairs G" using NegChecks 5(1) by auto
      have **: "fv (θ x)  set X = {}" using NegChecks 5(2) by simp
      have ***: "θ x =  x" using NegChecks 5(3) by auto
      have "fv (θ x)  fvpairs (F pairs )  fvpairs (G pairs )"
        using fvpairs_subst_fv_subset[of x _ ] * *** by auto
      thus ?thesis using NegChecks ** by auto
    qed (metis (full_types) 1 5(1) 3(1) 4(1), metis (full_types) 1 5(1) 3(2) 4(2),
         metis (full_types) 2 5(1) 3(3) 4(3), metis (full_types) 2 5(1) 3(4) 4(4),
         metis (full_types) 2 5(1) 3(5) 4(5), metis (full_types) 2 5(1) 3(6) 4(6))
    thus ?thesis by (auto simp add: subst_sst_cons[of a S θ])
  qed (auto simp add: subst_sst_cons[of a S θ])
qed simp

lemma (in intruder_model) wftrms_trmssst_subst:
  assumes "wftrms (trmssst A set δ)"
  shows "wftrms (trmssst (A sst δ))"
  using assms
proof (induction A)
  case (Cons a A)
  hence IH: "wftrms (trmssst (A sst δ))" and *: "wftrms (trmssstp a set δ)" by auto
  have "wftrms (trmssstp (a sstp δ))" by (rule wftrms_trmssstp_subst[OF *])
  thus ?case using IH trmssst_subst_cons[of a A δ] by blast
qed simp

lemma fvsst_subst_obtain_var:
  assumes "x  fvsst (S sst δ)"
  shows "y  fvsst S. x  fv (δ y)"
  using assms
proof (induction S)
  case (Cons s S)
  hence "x  fvsst (S sst δ)  y  fvsst S. x  fv (δ y)"
    using bvarssst_cons_subset[of S s]
    by blast
  thus ?case
  proof (cases "x  fvsst (S sst δ)")
    case False
    hence *: "x  fvsstp (s sstp δ)"
      using Cons.prems(1) subst_sst_cons[of s S δ]
      by fastforce

    have "y  fvsstp s. x  fv (δ y)"
    proof (cases s)
      case (NegChecks X F G)
      hence "x  fvpairs (F pairs rm_vars (set X) δ)  x  fvpairs (G pairs rm_vars (set X) δ)"
          and **: "x  set X"
        using * by simp_all
      then obtain y where y: "y  fvpairs F  y  fvpairs G" "x  fv ((rm_vars (set X) δ) y)"
        using fvpairs_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
        by blast
      have "y  set X"
      proof
        assume y_in: "y  set X"
        hence "(rm_vars (set X) δ) y = Var y" by auto
        hence "x = y" using y(2) by simp
        thus False using ** y_in by metis
      qed
      thus ?thesis using NegChecks y by auto
    qed (use * fv_subst_obtain_var in force)+
    thus ?thesis by auto
  qed auto
qed simp

lemma fvsst_subst_subset_range_vars_if_subset_domain:
  assumes "fvsst S  subst_domain σ"
  shows "fvsst (S sst σ)  range_vars σ"
using assms fvsst_subst_obtain_var[of _ S σ] subst_dom_vars_in_subst[of _ σ] subst_fv_imgI[of σ]
by (metis (no_types) in_mono subsetI)

lemma fvsst_in_fv_trmssst: "x  fvsst S  x  fvset (trmssst S)"
proof (induction S)
  case (Cons s S) thus ?case
  proof (cases "x  fvsst S")
    case False
    hence *: "x  fvsstp s" using Cons.prems by simp
    hence "x  fvset (trmssstp s)"
    proof (cases s)
      case (NegChecks X F G)
      hence "x  fvpairs F  x  fvpairs G" using * by simp_all
      thus ?thesis using * fvpairs_in_fv_trmspairs[of x] NegChecks by auto
    qed auto
    thus ?thesis by simp
  qed simp
qed simp

lemma stateful_strand_step_subst_comp:
  assumes "range_vars δ  set (bvarssstp x) = {}"
  shows "x sstp δ s θ = (x sstp δ) sstp θ"
proof (cases x)
  case (NegChecks X F G)
  hence *: "range_vars δ  set X = {}" using assms by simp
  have "H pairs rm_vars (set X) (δ s θ) = (H pairs rm_vars (set X) δ) pairs rm_vars (set X) θ" for H
    using pairs_subst_comp rm_vars_comp[OF *] by (induct H) (auto simp add: subst_apply_pairs_def)
  thus ?thesis using NegChecks by simp
qed simp_all

lemma stateful_strand_subst_comp:
  assumes "range_vars δ  bvarssst S = {}"
  shows "S sst δ s θ = (S sst δ) sst θ"
using assms
proof (induction S)
  case (Cons s S)
  hence IH: "S sst δ s θ = (S sst δ) sst θ" using Cons by auto

  have "s sstp δ s θ = (s sstp δ) sstp θ"
    using Cons.prems stateful_strand_step_subst_comp[of δ s θ]
    unfolding range_vars_alt_def by auto
  thus ?case using IH by (simp add: subst_apply_stateful_strand_def)
qed simp

lemma subst_apply_bvars_disj_NegChecks:
  assumes "set X  subst_domain θ = {}"
  shows "NegChecks X F G sstp θ = NegChecks X (F pairs θ) (G pairs θ)"
proof -
  have "rm_vars (set X) θ = θ" using assms rm_vars_apply'[of θ "set X"] by auto
  thus ?thesis by simp
qed

lemma subst_apply_NegChecks_no_bvars[simp]:
  "[]⟨∨≠: F ∨∉: F' sstp θ = []⟨∨≠: (F pairs θ) ∨∉: (F' pairs θ)"
  "[]⟨∨≠: [] ∨∉: F' sstp θ = []⟨∨≠: [] ∨∉: (F' pairs θ)"
  "[]⟨∨≠: F ∨∉: [] sstp θ = []⟨∨≠: (F pairs θ) ∨∉: []"
  "[]⟨∨≠: [] ∨∉: [(t,s)] sstp θ = []⟨∨≠: [] ∨∉: ([(t  θ,s  θ)])" (is ?A)
  "[]⟨∨≠: [(t,s)] ∨∉: [] sstp θ = []⟨∨≠: ([(t  θ,s  θ)]) ∨∉: []" (is ?B)
by simp_all

lemma setopssst_mono:
  "set M  set N  setopssst M  setopssst N"
by (auto simp add: setopssst_def)

lemma setopssst_nil[simp]: "setopssst [] = {}"
by (simp add: setopssst_def)

lemma setopssst_cons[simp]: "setopssst (a#A) = setopssstp a  setopssst A"
by (simp add: setopssst_def)

lemma setopssst_cons_subset[simp]: "setopssst A  setopssst (a#A)"
using setopssst_cons[of a A] by blast

lemma setopssst_append: "setopssst (A@B) = setopssst A  setopssst B"
proof (induction A)
  case (Cons a A) thus ?case by (cases a) (auto simp add: setopssst_def)
qed (simp add: setopssst_def)

lemma setopssstp_member_iff:
  "(t,s)  setopssstp x 
    (x = Insert t s  x = Delete t s  (ac. x = InSet ac t s) 
     (X F F'. x = NegChecks X F F'  (t,s)  set F'))"
by (cases x) auto

lemma setopssst_member_iff:
  "(t,s)  setopssst A 
    (Insert t s  set A  Delete t s  set A  (ac. InSet ac t s  set A) 
     (X F F'. NegChecks X F F'  set A  (t,s)  set F'))"
  (is "?P  ?Q")
proof (induction A)
  case (Cons a A) thus ?case
  proof (cases "(t, s)  setopssstp a")
    case True thus ?thesis using setopssstp_member_iff[of t s a] by auto
  qed auto
qed simp

lemma setopssstp_subst:
  assumes "set (bvarssstp a)  subst_domain θ = {}"
  shows "setopssstp (a sstp θ) = setopssstp a pset θ"
proof (cases a)
  case (NegChecks X F G)
  hence "rm_vars (set X) θ = θ" using assms rm_vars_apply'[of θ "set X"] by auto
  hence "setopssstp (a sstp θ) = set (G pairs θ)"
        "setopssstp a pset θ = set G pset θ"
    using NegChecks image_Un by simp_all
  thus ?thesis by (simp add: subst_apply_pairs_def) 
qed simp_all

lemma setopssstp_subst':
  assumes "¬is_NegChecks a"
  shows "setopssstp (a sstp θ) = setopssstp a pset θ"
using assms by (cases a) auto

lemma setopssstp_subst'':
  fixes t::"('a,'b) term × ('a,'b) term" and δ::"('a,'b) subst"
  assumes t: "t  setopssstp (b sstp δ)"
  shows "s  setopssstp b. t = s p rm_vars (set (bvarssstp b)) δ"
proof (cases "is_NegChecks b")
  case True
  then obtain X F G where b: "b = NegChecks X F G" by (cases b) moura+
  hence "setopssstp b = set G" "setopssstp (b sstp δ) = set (G pairs rm_vars (set (bvarssstp b)) δ)"
    by simp_all
  thus ?thesis using t subst_apply_pairs_pset_subst[of G] by blast
next
  case False
  hence "setopssstp (b sstp δ) = setopssstp b pset rm_vars (set (bvarssstp b)) δ"
    using setopssstp_subst' bvarssstp_NegChecks by fastforce
  thus ?thesis using t by blast
qed

lemma setopssst_subst:
  assumes "bvarssst S  subst_domain θ = {}"
  shows "setopssst (S sst θ) = setopssst S pset θ"
using assms
proof (induction S)
  case (Cons a S)
  have "bvarssst S  subst_domain θ = {}" and *: "set (bvarssstp a)  subst_domain θ = {}"
    using Cons.prems by auto
  hence IH: "setopssst (S sst θ) = setopssst S pset θ"
    using Cons.IH by auto
  show ?case
    using setopssstp_subst[OF *] IH unfolding setopssst_def
    by (auto simp add: subst_apply_stateful_strand_def)
qed (simp add: setopssst_def)

lemma setopssst_subst':
  fixes p::"('a,'b) term × ('a,'b) term" and δ::"('a,'b) subst"
  assumes "p  setopssst (S sst δ)"
  shows "s  setopssst S. X. set X  bvarssst S  p = s p rm_vars (set X) δ"
using assms
proof (induction S)
  case (Cons a S)
  note 0 = setopssst_cons[of a S] bvarssst_Cons[of a S]
  note 1 = setopssst_cons[of "a sstp δ" "S sst δ"] subst_sst_cons[of a S δ]
  have "p  setopssst (S sst δ)  p  setopssstp (a sstp δ)" using Cons.prems 1 by auto
  thus ?case
  proof
    assume *: "p  setopssstp (a sstp δ)"
    show ?thesis using setopssstp_subst''[OF *] 0 by blast
  next
    assume *: "p  setopssst (S sst δ)"
    show ?thesis using Cons.IH[OF *] 0 by blast
  qed
qed simp


subsection ‹Stateful Constraint Semantics›
context intruder_model
begin

definition negchecks_model where
  "negchecks_model (::('a,'b) subst) (D::('a,'b) dbstate) X F G 
      (δ. subst_domain δ = set X  ground (subst_range δ)  
              (list_ex (λf. fst f  (δ s )  snd f  (δ s )) F 
               list_ex (λf. f p (δ s )  D) G))"

fun strand_sem_stateful::
  "('fun,'var) terms  ('fun,'var) dbstate  ('fun,'var) stateful_strand  ('fun,'var) subst  bool"
  ("_; _; _s")
where
  "M; D; []s = (λ. True)"
| "M; D; Send t#Ss = (λ. M  t    M; D; Ss )"
| "M; D; Receive t#Ss = (λ. insert (t  ) M; D; Ss )"
| "M; D; Equality _ t t'#Ss = (λ. t   = t'    M; D; Ss )"
| "M; D; Insert t s#Ss = (λ. M; insert ((t,s) p ) D; Ss )"
| "M; D; Delete t s#Ss = (λ. M; D - {(t,s) p }; Ss )"
| "M; D; InSet _ t s#Ss = (λ. (t,s) p   D  M; D; Ss )"
| "M; D; NegChecks X F F'#Ss = (λ. negchecks_model  D X F F'  M; D; Ss )"


lemmas strand_sem_stateful_induct =
  strand_sem_stateful.induct[case_names Nil ConsSnd ConsRcv ConsEq
                                        ConsIns ConsDel ConsIn ConsNegChecks]

abbreviation constr_sem_stateful (infix "s" 91) where " s A  {}; {}; As "

lemma stateful_strand_sem_NegChecks_no_bvars:
  "M; D; [t not in s]s   (t  , s  )  D"
  "M; D; [t != s]s   t    s  "
by (simp_all add: negchecks_model_def empty_dom_iff_empty_subst)

lemma strand_sem_ik_mono_stateful:
  "M; D; As   M  M'; D; As "
using ideduct_mono by (induct A arbitrary: M M' D rule: strand_sem_stateful.induct) force+

lemma strand_sem_append_stateful:
  "M; D; A@Bs   M; D; As   M  (iksst A set ); dbupdsst A  D; Bs "
  (is "?P  ?Q  ?R")
proof -
  have 1: "?P  ?Q" by (induct A rule: strand_sem_stateful.induct) auto

  have 2: "?P  ?R"
  proof (induction A arbitrary: M D B)
    case (Cons a A) thus ?case
    proof (cases a)
      case (Receive t)
      have "insert (t  ) (M  (iksst A set )) = M  (iksst (a#A) set )"
           "dbupdsst A  D = dbupdsst (a#A)  D"
        using Receive by (auto simp add: iksst_def)
      thus ?thesis using Cons Receive by force
    qed (auto simp add: iksst_def)
  qed (simp add: iksst_def)

  have 3: "?Q  ?R  ?P"
  proof (induction A arbitrary: M D)
    case (Cons a A) thus ?case
    proof (cases a)
      case (Receive t)
      have "insert (t  ) (M  (iksst A set )) = M  (iksst (a#A) set )"
           "dbupdsst A  D = dbupdsst (a#A)  D"
        using Receive by (auto simp add: iksst_def)
      thus ?thesis using Cons Receive by simp
    qed (auto simp add: iksst_def)
  qed (simp add: iksst_def)

  show ?thesis by (metis 1 2 3)
qed

lemma negchecks_model_db_subset:
  fixes F F'::"(('a,'b) term × ('a,'b) term) list"
  assumes "D'  D"
  and "negchecks_model  D X F F'"
  shows "negchecks_model  D' X F F'"
proof -
  have "list_ex (λf. f p δ s   D') F'"
    when "list_ex (λf. f p δ s   D) F'"
    for δ::"('a,'b) subst"
    using Bex_set[of F' "λf. f p δ s   D'"]
          Bex_set[of F' "λf. f p δ s   D"]
          that assms(1)
    by blast
  thus ?thesis using assms(2) by (auto simp add: negchecks_model_def)
qed

lemma negchecks_model_db_supset:
  fixes F F'::"(('a,'b) term × ('a,'b) term) list"
  assumes "D'  D"
    and "f  set F'. δ. subst_domain δ = set X  ground (subst_range δ)  f p (δ s )  D - D'"
    and "negchecks_model  D' X F F'"
  shows "negchecks_model  D X F F'"
proof -
  have "list_ex (λf. f p δ s   D) F'"
    when "list_ex (λf. f p δ s   D') F'" "subst_domain δ = set X  ground (subst_range δ)"
    for δ::"('a,'b) subst"
    using Bex_set[of F' "λf. f p δ s   D'"]
          Bex_set[of F' "λf. f p δ s   D"]
          that assms(1,2)
    by blast
  thus ?thesis using assms(3) by (auto simp add: negchecks_model_def)
qed

lemma negchecks_model_subst:
  fixes F F'::"(('a,'b) term × ('a,'b) term) list"
  assumes "(subst_domain δ  range_vars δ)  set X = {}"
  shows "negchecks_model (δ s θ) D X F F'  negchecks_model θ D X (F pairs δ) (F' pairs δ)"
proof -
  have 0: "σ s (δ s θ) = δ s (σ s θ)"
    when σ: "subst_domain σ = set X" "ground (subst_range σ)" for σ
    by (metis (no_types, lifting) σ subst_compose_assoc assms(1) inf_sup_aci(1)
            subst_comp_eq_if_disjoint_vars sup_inf_absorb range_vars_alt_def)

  { fix σ::"('a,'b) subst" and t t'
    assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
        and *: "list_ex (λf. fst f  (σ s (δ s θ))  snd f  (σ s (δ s θ))) F"
    obtain f where f: "f  set F" "fst f  σ s (δ s θ)  snd f  σ s (δ s θ)"
      using * by (induct F) auto
    hence "(fst f  δ)  σ s θ  (snd f  δ)  σ s θ" using 0[OF σ] by simp
    moreover have "(fst f  δ, snd f  δ)  set (F pairs δ)"
      using f(1) by (auto simp add: subst_apply_pairs_def)
    ultimately have "list_ex (λf. fst f  (σ s θ)  snd f  (σ s θ)) (F pairs δ)"
      using f(1) Bex_set by fastforce
  } moreover {
    fix σ::"('a,'b) subst" and t t'
    assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
        and *: "list_ex (λf. f p σ s (δ s θ)  D) F'"
    obtain f where f: "f  set F'" "f p σ s (δ s θ)  D"
      using * by (induct F') auto
    hence "f p δ p σ s θ  D" using 0[OF σ] by (metis subst_pair_compose)
    moreover have "f p δ  set (F' pairs δ)"
      using f(1) by (auto simp add: subst_apply_pairs_def)
    ultimately have "list_ex (λf. f p σ s θ  D) (F' pairs δ)"
      using f(1) Bex_set by fastforce
  } moreover {
    fix σ::"('a,'b) subst" and t t'
    assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
        and *: "list_ex (λf. fst f  (σ s θ)  snd f  (σ s θ)) (F pairs δ)"
    obtain f where f: "f  set (F pairs δ)" "fst f  σ s θ  snd f  σ s θ"
      using * by (induct F) (auto simp add: subst_apply_pairs_def)
    then obtain g where g: "g  set F" "f = g p δ" by (auto simp add: subst_apply_pairs_def)
    have "fst g  σ s (δ s θ)  snd g  σ s (δ s θ)"
      using f(2) g 0[OF σ] by (simp add: prod.case_eq_if)
    hence "list_ex (λf. fst f  (σ s (δ s θ))  snd f  (σ s (δ s θ))) F"
      using g Bex_set by fastforce
  } moreover {
    fix σ::"('a,'b) subst" and t t'
    assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
        and *: "list_ex (λf. f p (σ s θ)  D) (F' pairs δ)"
    obtain f where f: "f  set (F' pairs δ)" "f p σ s θ  D"
      using * by (induct F') (auto simp add: subst_apply_pairs_def)
    then obtain g where g: "g  set F'" "f = g p δ" by (auto simp add: subst_apply_pairs_def)
    have "g p σ s (δ s θ)  D"
      using f(2) g 0[OF σ] by (simp add: prod.case_eq_if)
    hence "list_ex (λf. f p (σ s (δ s θ))  D) F'"
      using g Bex_set by fastforce
  } ultimately show ?thesis using assms unfolding negchecks_model_def by blast
qed

lemma strand_sem_subst_stateful:
  fixes δ::"('fun,'var) subst"
  assumes "(subst_domain δ  range_vars δ)  bvarssst S = {}"
  shows "M; D; Ss (δ s θ)  M; D; S sst δs θ"
proof
  note [simp] = subst_sst_cons[of _ _ δ] subst_subst_compose[of _ δ θ]

  have "(subst_domain δ  range_vars δ)  (subst_domain γ  range_vars γ) = {}"
    when δ: "(subst_domain δ  range_vars δ)  set X = {}"
      and γ: "subst_domain γ = set X" "ground (subst_range γ)"
    for X and γ::"('fun,'var) subst"
    using δ γ unfolding range_vars_alt_def by auto
  hence 0: "γ s δ = δ s γ"
    when δ: "(subst_domain δ  range_vars δ)  set X = {}"
      and γ: "subst_domain γ = set X" "ground (subst_range γ)"
    for γ X
    by (metis δ γ subst_comp_eq_if_disjoint_vars)

  show "M; D; Ss (δ s θ)  M; D; S sst δs θ" using assms
  proof (induction S arbitrary: M D rule: strand_sem_stateful_induct)
    case (ConsNegChecks M D X F F' S)
    hence *: "M; D; S sst δs θ" and **: "(subst_domain δ  range_vars δ)  set X = {}"
      unfolding bvarssst_def negchecks_model_def by (force, auto)
    have "negchecks_model (δ s θ) D X F F'" using ConsNegChecks by auto
    hence "negchecks_model θ D X (F pairs δ) (F' pairs δ)"
      using 0[OF **] negchecks_model_subst[OF **] by blast
    moreover have "rm_vars (set X) δ = δ" using ConsNegChecks.prems(2) by force
    ultimately show ?case using * by auto
  qed simp_all

  show "M; D; S sst δs θ  M; D; Ss (δ s θ)" using assms
  proof (induction S arbitrary: M D rule: strand_sem_stateful_induct)
    case (ConsNegChecks M D X F F' S)
    have δ: "rm_vars (set X) δ = δ" using ConsNegChecks.prems(2) by force
    hence *: "M; D; Ss (δ s θ)" and **: "(subst_domain δ  range_vars δ)  set X = {}"
      using ConsNegChecks unfolding bvarssst_def negchecks_model_def by auto
    have "negchecks_model θ D X (F pairs δ) (F' pairs δ)"
      using ConsNegChecks.prems(1) δ by (auto simp add: subst_compose_assoc negchecks_model_def)
    hence "negchecks_model (δ s θ) D X F F'"
      using 0[OF **] negchecks_model_subst[OF **] by blast
    thus ?case using * by auto
  qed simp_all
qed

end


subsection ‹Well-Formedness Lemmata›
lemma wfvarsoccsst_subset_wfrestrictedvarssst[simp]:
  "wfvarsoccssst S  wfrestrictedvarssst S"
by (induction S)
   (auto simp add: wfrestrictedvarssst_def wfvarsoccssst_def
         split: stateful_strand_step.split poscheckvariant.split)

lemma wfvarsoccssst_append: "wfvarsoccssst (S@S') = wfvarsoccssst S  wfvarsoccssst S'"
by (simp add: wfvarsoccssst_def)

lemma wfrestrictedvarssst_union[simp]:
  "wfrestrictedvarssst (S@T) = wfrestrictedvarssst S  wfrestrictedvarssst T"
by (simp add: wfrestrictedvarssst_def)

lemma wfrestrictedvarssst_singleton:
  "wfrestrictedvarssst [s] = wfrestrictedvarssstp s"
by (simp add: wfrestrictedvarssst_def)

lemma wfsst_prefix[dest]: "wf'sst V (S@S')  wf'sst V S"
by (induct S rule: wf'sst.induct) auto

lemma wfsst_vars_mono: "wf'sst V S  wf'sst (V  W) S"
proof (induction S arbitrary: V)
  case (Cons x S) thus ?case
  proof (cases x)
    case (Send t)
    hence "wf'sst (V  fv t  W) S" using Cons.prems(1) Cons.IH by simp
    thus ?thesis using Send by (simp add: sup_commute sup_left_commute)
  next
    case (Equality a t t')
    show ?thesis
    proof (cases a)
      case Assign
      hence "wf'sst (V  fv t  W) S" "fv t'  V  W" using Equality Cons.prems(1) Cons.IH by auto
      thus ?thesis using Equality Assign by (simp add: sup_commute sup_left_commute)
    next
      case Check thus ?thesis using Equality Cons by auto
    qed
  next
    case (InSet a t t')
    show ?thesis
    proof (cases a)
      case Assign
      hence "wf'sst (V  fv t  fv t'  W) S" using InSet Cons.prems(1) Cons.IH by auto
      thus ?thesis using InSet Assign by (simp add: sup_commute sup_left_commute)
    next
      case Check thus ?thesis using InSet Cons by auto
    qed
  qed auto
qed simp

lemma wfsstI[intro]: "wfrestrictedvarssst S  V  wf'sst V S"
proof (induction S)
  case (Cons x S) thus ?case
  proof (cases x)
    case (Send t)
    hence "wf'sst V S" "V  fv t = V"
      using Cons
      unfolding wfrestrictedvarssst_def
      by auto
    thus ?thesis using Send by simp
  next
    case (Equality a t t')
    show ?thesis
    proof (cases a)
      case Assign
      hence "wf'sst V S" "fv t'  V"
        using Equality Cons 
        unfolding wfrestrictedvarssst_def
        by auto
      thus ?thesis using wfsst_vars_mono Equality Assign by simp
    next
      case Check
      thus ?thesis
        using Equality Cons
        unfolding wfrestrictedvarssst_def
        by auto
    qed
  next
    case (InSet a t t')
    show ?thesis
    proof (cases a)
      case Assign
      hence "wf'sst V S" "fv t  fv t'  V"
        using InSet Cons
        unfolding wfrestrictedvarssst_def
        by auto
      thus ?thesis using wfsst_vars_mono InSet Assign by (simp add: Un_assoc) 
    next
      case Check
      thus ?thesis
        using InSet Cons
        unfolding wfrestrictedvarssst_def
        by auto
    qed
  qed (simp_all add: wfrestrictedvarssst_def)
qed (simp add: wfrestrictedvarssst_def)

lemma wfsstI'[intro]:
  assumes "((λx. case x of
            Receive t  fv t
          | Equality Assign _ t'  fv t'
          | Insert t t'  fv t  fv t'
          | _  {}) ` set S)  V"
  shows "wf'sst V S"
using assms
proof (induction S)
  case (Cons x S) thus ?case
  proof (cases x)
    case (Equality a t t')
    thus ?thesis using Cons by (cases a) (auto simp add: wfsst_vars_mono)
  next
    case (InSet a t t')
    thus ?thesis using Cons by (cases a) (auto simp add: wfsst_vars_mono Un_assoc)
  qed (simp_all add: wfsst_vars_mono)
qed simp

lemma wfsst_append_exec: "wf'sst V (S@S')  wf'sst (V  wfvarsoccssst S) S'"
proof (induction S arbitrary: V)
  case (Cons x S V) thus ?case
  proof (cases x)
    case (Send t)
    hence "wf'sst (V  fv t  wfvarsoccssst S) S'" using Cons.prems Cons.IH by simp
    thus ?thesis using Send unfolding wfvarsoccssst_def by (auto simp add: sup_assoc)
  next
    case (Equality a t t') show ?thesis
    proof (cases a)
      case Assign
      hence "wf'sst (V  fv t  wfvarsoccssst S) S'" using Equality Cons.prems Cons.IH by auto
      thus ?thesis using Equality Assign unfolding wfvarsoccssst_def by (auto simp add: sup_assoc)
    next
      case Check
      hence "wf'sst (V  wfvarsoccssst S) S'" using Equality Cons.prems Cons.IH by auto
      thus ?thesis using Equality Check unfolding wfvarsoccssst_def by (auto simp add: sup_assoc)
    qed
  next
    case (InSet a t t') show ?thesis
    proof (cases a)
      case Assign
      hence "wf'sst (V  fv t  fv t'  wfvarsoccssst S) S'" using InSet Cons.prems Cons.IH by auto
      thus ?thesis using InSet Assign unfolding wfvarsoccssst_def by (auto simp add: sup_assoc)
    next
      case Check
      hence "wf'sst (V  wfvarsoccssst S) S'" using InSet Cons.prems Cons.IH by auto
      thus ?thesis using InSet Check unfolding wfvarsoccssst_def by (auto simp add: sup_assoc)
    qed
  qed (auto simp add: wfvarsoccssst_def)
qed (simp add: wfvarsoccssst_def)

lemma wfsst_append:
  "wf'sst X S  wf'sst Y T  wf'sst (X  Y) (S@T)"
proof (induction X S rule: wf'sst.induct)
  case 1 thus ?case by (metis wfsst_vars_mono Un_commute append_Nil)
next
  case 3 thus ?case by (metis append_Cons Un_commute Un_assoc wf'sst.simps(3))
next
  case (4 V t t' S)
  hence *: "fv t'  V" and "wf'sst (V  fv t  Y) (S @ T)" by simp_all
  hence "wf'sst (V  Y  fv t) (S @ T)" by (metis Un_commute Un_assoc)
  thus ?case using * by auto
next
  case (8 V t t' S)
  hence "wf'sst (V  fv t  fv t'  Y) (S @ T)" by simp_all
  hence "wf'sst (V  Y  fv t  fv t') (S @ T)" by (metis Un_commute Un_assoc)
  thus ?case by auto
qed auto

lemma wfsst_append_suffix:
  "wf'sst V S  wfrestrictedvarssst S'  wfrestrictedvarssst S  V  wf'sst V (S@S')"
proof (induction V S rule: wf'sst.induct)
  case (2 V t S)
  hence *: "fv t  V" "wf'sst V S" by simp_all
  hence "wfrestrictedvarssst S'  wfrestrictedvarssst S  V"
    using "2.prems"(2) unfolding wfrestrictedvarssst_def by auto
  thus ?case using "2.IH" * by simp
next
  case (3 V t S)
  hence *: "wf'sst (V  fv t) S" by simp_all
  hence "wfrestrictedvarssst S'  wfrestrictedvarssst S  (V  fv t)"
    using "3.prems"(2) unfolding wfrestrictedvarssst_def by auto
  thus ?case using "3.IH" * by simp
next
  case (4 V t t' S)
  hence *: "fv t'  V" "wf'sst (V  fv t) S" by simp_all
  moreover have "varssstp (t := t') = fv t  fv t'"
    by simp
  moreover have "wfrestrictedvarssst (t := t'#S) = fv t  fv t'  wfrestrictedvarssst S"
    unfolding wfrestrictedvarssst_def by auto
  ultimately have "wfrestrictedvarssst S'  wfrestrictedvarssst S  (V  fv t)"
    using "4.prems"(2) by blast
  thus ?case using "4.IH" * by simp
next
  case (6 V t t' S)
  hence *: "fv t  fv t'  V" "wf'sst V S" by simp_all
  moreover have "varssstp (insert⟨t,t') = fv t  fv t'"
    by simp
  moreover have "wfrestrictedvarssst (insert⟨t,t'#S) = fv t  fv t'  wfrestrictedvarssst S"
    unfolding wfrestrictedvarssst_def by auto
  ultimately have "wfrestrictedvarssst S'  wfrestrictedvarssst S  V"
    using "6.prems"(2) by blast
  thus ?case using "6.IH" * by simp
next
  case (8 V t t' S)
  hence *: "wf'sst (V  fv t  fv t') S" by simp_all
  moreover have "varssstp (select⟨t,t') = fv t  fv t'"
    by simp
  moreover have "wfrestrictedvarssst (select⟨t,t'#S) = fv t  fv t'  wfrestrictedvarssst S"
    unfolding wfrestrictedvarssst_def by auto
  ultimately have "wfrestrictedvarssst S'  wfrestrictedvarssst S  (V  fv t  fv t')"
    using "8.prems"(2) by blast
  thus ?case using "8.IH" * by simp
qed (simp_all add: wfsstI wfrestrictedvarssst_def)

lemma wfsst_append_suffix':
  assumes "wf'sst V S"
    and "((λx. case x of
            Receive t  fv t
          | Equality Assign _ t'  fv t'
          | Insert t t'  fv t  fv t'
          | _  {}) ` set S')  wfvarsoccssst S  V"
  shows "wf'sst V (S@S')"
using assms
by (induction V S rule: wf'sst.induct)
   (auto simp add: wfsstI' wfsst_vars_mono wfvarsoccssst_def)

lemma wfsst_subst_apply:
  "wf'sst V S  wf'sst (fvset (δ ` V)) (S sst δ)"
proof (induction S arbitrary: V rule: wf'sst.induct)
  case (2 V t S)
  hence "wf'sst V S" "fv t  V" by simp_all
  hence "wf'sst (fvset (δ ` V)) (S sst δ)" "fv (t  δ)  fvset (δ ` V)"
    using "2.IH" subst_apply_fv_subset by simp_all
  thus ?case by (simp add: subst_apply_stateful_strand_def)
next
  case (3 V t S)
  hence "wf'sst (V  fv t) S" by simp
  hence "wf'sst (fvset (δ ` (V  fv t))) (S sst δ)" using "3.IH" by metis
  hence "wf'sst (fvset (δ ` V)  fv (t  δ)) (S sst δ)" by (metis subst_apply_fv_union)
  thus ?case by (simp add: subst_apply_stateful_strand_def)
next
  case (4 V t t' S)
  hence "wf'sst (V  fv t) S" "fv t'  V" by auto
  hence "wf'sst (fvset (δ ` (V  fv t))) (S sst δ)" and *: "fv (t'  δ)  fvset (δ ` V)"
    using "4.IH" subst_apply_fv_subset by force+
  hence "wf'sst (fvset (δ ` V)  fv (t  δ)) (S sst δ)" by (metis subst_apply_fv_union)
  thus ?case using * by (simp add: subst_apply_stateful_strand_def)
next
  case (6 V t t' S)
  hence "wf'sst V S" "fv t  fv t'  V" by auto
  hence "wf'sst (fvset (δ ` V)) (S sst δ)" "fv (t  δ)  fvset (δ ` V)" "fv (t'  δ)  fvset (δ ` V)"
    using "6.IH" subst_apply_fv_subset by force+
  thus ?case by (simp add: sup_assoc subst_apply_stateful_strand_def)
next
  case (8 V t t' S)
  hence "wf'sst (V  fv t  fv t') S" by auto
  hence "wf'sst (fvset (δ ` (V  fv t  fv t'))) (S sst δ)"
    using "8.IH" subst_apply_fv_subset by force
  hence "wf'sst (fvset (δ ` V)  fv (t  δ)  fv (t'  δ)) (S sst δ)" by (metis subst_apply_fv_union)
  thus ?case by (simp add: subst_apply_stateful_strand_def)
qed (auto simp add: subst_apply_stateful_strand_def)

end

Theory Stateful_Typing

(*
(C) Copyright Andreas Viktor Hess, DTU, 2018-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Stateful_Typing.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹Extending the Typing Result to Stateful Constraints›
text ‹\label{sec:Stateful-Typing}›

theory Stateful_Typing
imports Typing_Result Stateful_Strands
begin

text ‹Locale setup›
locale stateful_typed_model = typed_model arity public Ana Γ
  for arity::"'fun  nat"
    and public::"'fun  bool"
    and Ana::"('fun,'var) term  (('fun,'var) term list × ('fun,'var) term list)"
    and Γ::"('fun,'var) term  ('fun,'atom::finite) term_type"
  +
  fixes Pair::"'fun"
  assumes Pair_arity: "arity Pair = 2"
  and Ana_subst': "f T δ K M. Ana (Fun f T) = (K,M)  Ana (Fun f T  δ) = (K list δ,M list δ)"
begin

lemma Ana_invar_subst'[simp]: "Ana_invar_subst 𝒮"
using Ana_subst' unfolding Ana_invar_subst_def by force

definition pair where
  "pair d  case d of (t,t')  Fun Pair [t,t']"

fun trpairs::
  "(('fun,'var) term × ('fun,'var) term) list 
   ('fun,'var) dbstatelist 
   (('fun,'var) term × ('fun,'var) term) list list"
where
  "trpairs [] D = [[]]"
| "trpairs ((s,t)#F) D =
    concat (map (λd. map ((#) (pair (s,t), pair d)) (trpairs F D)) D)"

text ‹
  A translation/reduction tr› from stateful constraints to (lists of) "non-stateful" constraints.
  The output represents a finite disjunction of constraints whose models constitute exactly the
  models of the input constraint. The typing result for "non-stateful" constraints is later lifted
  to the stateful setting through this reduction procedure.
›
fun tr::"('fun,'var) stateful_strand  ('fun,'var) dbstatelist  ('fun,'var) strand list"
where
  "tr [] D = [[]]"
| "tr (send⟨t#A) D = map ((#) (send⟨tst)) (tr A D)"
| "tr (receive⟨t#A) D = map ((#) (receive⟨tst)) (tr A D)"
| "tr (ac: t  t'#A) D = map ((#) (ac: t  t'st)) (tr A D)"
| "tr (insert⟨t,s#A) D = tr A (List.insert (t,s) D)"
| "tr (delete⟨t,s#A) D =
    concat (map (λDi. map (λB. (map (λd. check: (pair (t,s))  (pair d)st) Di)@
                               (map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di])@B)
                          (tr A [dD. d  set Di]))
                (subseqs D))"
| "tr (ac: t  s#A) D =
    concat (map (λB. map (λd. ac: (pair (t,s))  (pair d)st#B) D) (tr A D))"
| "tr (X⟨∨≠: F ∨∉: F'#A) D =
    map ((@) (map (λG. X⟨∨≠: (F@G)st) (trpairs F' D))) (tr A D)"

text ‹Type-flaw resistance of stateful constraint steps›
fun tfrsstp where
  "tfrsstp (Equality _ t t') = ((δ. Unifier δ t t')  Γ t = Γ t')"
| "tfrsstp (NegChecks X F F') = (
    (F' = []  (x  fvpairs F-set X. a. Γ (Var x) = TAtom a)) 
    (f T. Fun f T  subtermsset (trmspairs F  pair ` set F') 
              T = []  (s  set T. s  Var ` set X)))"
| "tfrsstp _ = True"

text ‹Type-flaw resistance of stateful constraints›
definition tfrsst where "tfrsst S  tfrset (trmssst S  pair ` setopssst S)  list_all tfrsstp S"


subsection ‹Small Lemmata›
lemma pair_in_pair_image_iff:
  "pair (s,t)  pair ` P  (s,t)  P"
unfolding pair_def by fast

lemma subst_apply_pairs_pair_image_subst:
  "pair ` set (F pairs θ) = pair ` set F set θ"
unfolding subst_apply_pairs_def pair_def by (induct F) auto

lemma Ana_subst_subterms_cases:
  fixes θ::"('fun,'var) subst"
  assumes t: "t  subtermsset (M set θ)"
    and s: "s  set (snd (Ana t))"
  shows "(u  subtermsset M. t = u  θ  s  set (snd (Ana u)) set θ)  (x  fvset M. t  θ x)"
proof (cases "t  subtermsset M set θ")
  case True
  then obtain u where u: "u  subtermsset M" "t = u  θ" by moura
  show ?thesis
  proof (cases u)
    case (Var x)
    hence "x  fvset M" using fv_subset_subterms[OF u(1)] by simp
    thus ?thesis using u(2) Var by fastforce
  next
    case (Fun f T)
    hence "set (snd (Ana t)) = set (snd (Ana u)) set θ"
      using Ana_subst'[of f T _ _ θ] u(2) by (cases "Ana u") auto
    thus ?thesis using s u by blast
  qed
qed (use s t subtermsset_subst in blast)

lemma tfrsstp_alt_def:
  "list_all tfrsstp S =
    ((ac t t'. Equality ac t t'  set S  (δ. Unifier δ t t')  Γ t = Γ t') 
     (X F F'. NegChecks X F F'  set S  (
        (F' = []  (x  fvpairs F-set X. a. Γ (Var x) = TAtom a)) 
        (f T. Fun f T  subtermsset (trmspairs F  pair ` set F') 
                  T = []  (s  set T. s  Var ` set X)))))"
  (is "?P S = ?Q S")
proof
  show "?P S  ?Q S"
  proof (induction S)
    case (Cons x S) thus ?case by (cases x) auto
  qed simp

  show "?Q S  ?P S"
  proof (induction S)
    case (Cons x S) thus ?case by (cases x) auto
  qed simp
qed

lemma fun_pair_eq[dest]: "pair d = pair d'  d = d'"
proof -
  obtain t s t' s' where "d = (t,s)" "d' = (t',s')" by moura
  thus "pair d = pair d'  d = d'" unfolding pair_def by simp
qed

lemma fun_pair_subst: "pair d  δ = pair (d p δ)"
using surj_pair[of d] unfolding pair_def by force  

lemma fun_pair_subst_set: "pair ` M set δ = pair ` (M pset δ)"
proof
  show "pair ` M set δ  pair ` (M pset δ)"
    using fun_pair_subst[of _ δ] by fastforce

  show "pair ` (M pset δ)  pair ` M set δ"
  proof
    fix t assume t: "t  pair ` (M pset δ)"
    then obtain p where p: "p  M" "t = pair (p p δ)" by blast
    thus "t  pair ` M set δ" using fun_pair_subst[of p δ] by force
  qed
qed

lemma fun_pair_eq_subst: "pair d  δ = pair d'  θ  d p δ = d' p θ"
by (metis fun_pair_subst fun_pair_eq[of "d p δ" "d' p θ"])

lemma setopssst_pair_image_cons[simp]:
  "pair ` setopssst (x#S) = pair ` setopssstp x  pair ` setopssst S"
  "pair ` setopssst (send⟨t#S) = pair ` setopssst S"
  "pair ` setopssst (receive⟨t#S) = pair ` setopssst S"
  "pair ` setopssst (ac: t  t'#S) = pair ` setopssst S"
  "pair ` setopssst (insert⟨t,s#S) = {pair (t,s)}  pair ` setopssst S"
  "pair ` setopssst (delete⟨t,s#S) = {pair (t,s)}  pair ` setopssst S"
  "pair ` setopssst (ac: t  s#S) = {pair (t,s)}  pair ` setopssst S"
  "pair ` setopssst (X⟨∨≠: F ∨∉: G#S) = pair ` set G  pair ` setopssst S"
unfolding setopssst_def by auto

lemma setopssst_pair_image_subst_cons[simp]:
  "pair ` setopssst (x#S sst θ) = pair ` setopssstp (x sstp θ)  pair ` setopssst (S sst θ)"
  "pair ` setopssst (send⟨t#S sst θ) = pair ` setopssst (S sst θ)"
  "pair ` setopssst (receive⟨t#S sst θ) = pair ` setopssst (S sst θ)"
  "pair ` setopssst (ac: t  t'#S sst θ) = pair ` setopssst (S sst θ)"
  "pair ` setopssst (insert⟨t,s#S sst θ) = {pair (t,s)  θ}  pair ` setopssst (S sst θ)"
  "pair ` setopssst (delete⟨t,s#S sst θ) = {pair (t,s)  θ}  pair ` setopssst (S sst θ)"
  "pair ` setopssst (ac: t  s#S sst θ) = {pair (t,s)  θ}  pair ` setopssst (S sst θ)"
  "pair ` setopssst (X⟨∨≠: F ∨∉: G#S sst θ) =
    pair ` set (G pairs rm_vars (set X) θ)  pair ` setopssst (S sst θ)"
using subst_sst_cons[of _ S θ] unfolding setopssst_def pair_def by auto

lemma setopssst_are_pairs: "t  pair ` setopssst A  s s'. t = pair (s,s')"
proof (induction A)
  case (Cons a A) thus ?case
    by (cases a) (auto simp add: setopssst_def)
qed (simp add: setopssst_def)

lemma fun_pair_wftrm: "wftrm t  wftrm t'  wftrm (pair (t,t'))"
using Pair_arity unfolding wftrm_def pair_def by auto

lemma wftrms_pairs: "wftrms (trmspairs F)  wftrms (pair ` set F)"
using fun_pair_wftrm by blast

lemma tfrsst_Nil[simp]: "tfrsst []"
by (simp add: tfrsst_def setopssst_def)

lemma tfrsst_append: "tfrsst (A@B)  tfrsst A"
proof -
  assume assms: "tfrsst (A@B)"
  let ?M = "trmssst A  pair ` setopssst A"
  let ?N = "trmssst (A@B)  pair ` setopssst (A@B)"
  let ?P = "λt t'. x  fv t  fv t'. a. Γ (Var x) = Var a"
  let ?Q = "λX t t'. X = []  (x  (fv t  fv t')-set X. a. Γ (Var x) = Var a)"
  have *: "SMP ?M - Var`𝒱  SMP ?N - Var`𝒱" "?M  ?N"
    using SMP_mono[of ?M ?N] setopssst_append[of A B]
    by auto
  { fix s t assume **: "tfrset ?N" "s  SMP ?M - Var`𝒱" "t  SMP ?M - Var`𝒱" "(δ. Unifier δ s t)"
    hence "s  SMP ?N - Var`𝒱" "t  SMP ?N - Var`𝒱" using * by auto
    hence "Γ s = Γ t" using **(1,4) unfolding tfrset_def by blast
  } moreover have "t  ?N. wftrm t  t  ?M. wftrm t" using * by blast
  ultimately have "tfrset ?N  tfrset ?M" unfolding tfrset_def by blast
  hence "tfrset ?M" using assms unfolding tfrsst_def by metis
  thus "tfrsst A" using assms unfolding tfrsst_def by simp
qed

lemma tfrsst_append': "tfrsst (A@B)  tfrsst B"
proof -
  assume assms: "tfrsst (A@B)"
  let ?M = "trmssst B  pair ` setopssst B"
  let ?N = "trmssst (A@B)  pair ` setopssst (A@B)"
  let ?P = "λt t'. x  fv t  fv t'. a. Γ (Var x) = Var a"
  let ?Q = "λX t t'. X = []  (x  (fv t  fv t')-set X. a. Γ (Var x) = Var a)"
  have *: "SMP ?M - Var`𝒱  SMP ?N - Var`𝒱" "?M  ?N"
    using SMP_mono[of ?M ?N] setopssst_append[of A B]
    by auto
  { fix s t assume **: "tfrset ?N" "s  SMP ?M - Var`𝒱" "t  SMP ?M - Var`𝒱" "(δ. Unifier δ s t)"
    hence "s  SMP ?N - Var`𝒱" "t  SMP ?N - Var`𝒱" using * by auto
    hence "Γ s = Γ t" using **(1,4) unfolding tfrset_def by blast
  } moreover have "t  ?N. wftrm t  t  ?M. wftrm t" using * by blast
  ultimately have "tfrset ?N  tfrset ?M" unfolding tfrset_def by blast
  hence "tfrset ?M" using assms unfolding tfrsst_def by metis
  thus "tfrsst B" using assms unfolding tfrsst_def by simp
qed

lemma tfrsst_cons: "tfrsst (a#A)  tfrsst A"
using tfrsst_append'[of "[a]" A] by simp

lemma tfrsstp_subst:
  assumes s: "tfrsstp s"
    and θ: "wtsubst θ" "wftrms (subst_range θ)" "set (bvarssstp s)  range_vars θ = {}"
  shows "tfrsstp (s sstp θ)"
proof (cases s)
  case (Equality a t t')
  thus ?thesis
  proof (cases "δ. Unifier δ (t  θ) (t'  θ)")
    case True
    hence "δ. Unifier δ t t'" by (metis subst_subst_compose[of _ θ])
    moreover have "Γ t = Γ (t  θ)" "Γ t' = Γ (t'  θ)" by (metis wt_subst_trm''[OF assms(2)])+
    ultimately have "Γ (t  θ) = Γ (t'  θ)" using s Equality by simp
    thus ?thesis using Equality True by simp
  qed simp
next
  case (NegChecks X F G)
  let ?P = "λF G. G = []  (x  fvpairs F-set X. a. Γ (Var x) = TAtom a)"
  let ?Q = "λF G. f T. Fun f T  subtermsset (trmspairs F  pair ` set G) 
                          T = []  (s  set T. s  Var ` set X)"
  let  = "rm_vars (set X) θ"

  have "?P F G  ?Q F G" using NegChecks assms(1) by simp
  hence "?P (F pairs ) (G pairs )  ?Q (F pairs ) (G pairs )"
  proof
    assume *: "?P F G"
    have "G pairs  = []" using * by simp
    moreover have "a. Γ (Var x) = TAtom a" when x: "x  fvpairs (F pairs ) - set X" for x
    proof -
      obtain t t' where t: "(t,t')  set (F pairs )" "x  fv t  fv t' - set X"
        using x(1) by auto
      then obtain u u' where u: "(u,u')  set F" "u   = t" "u'   = t'"
        unfolding subst_apply_pairs_def by auto
      obtain y where y: "y  fv u  fv u' - set X" "x  fv ( y)"
        using t(2) u(2,3) rm_vars_fv_obtain by fast
      hence a: "a. Γ (Var y) = TAtom a" using u * by auto
      
      have a': "Γ (Var y) = Γ ( y)"
        using wt_subst_trm''[OF wt_subst_rm_vars[OF θ(1), of "set X"], of "Var y"]
        by simp

      have "(z.  y = Var z)  (c.  y = Fun c [])"
      proof (cases " y  subst_range θ")
        case True thus ?thesis
          using a a' θ(2) const_type_inv_wf
          by (cases " y") fastforce+
      qed fastforce
      hence " y = Var x" using y(2) by fastforce
      hence "Γ (Var x) = Γ (Var y)" using a' by simp
      thus ?thesis using a by presburger
    qed
    ultimately show ?thesis by simp
  next
    assume *: "?Q F G"
    have **: "set X  range_vars  = {}"
      using θ(3) NegChecks rm_vars_img_fv_subset[of "set X" θ] by auto
    have "?Q (F pairs ) (G pairs )"
      using ineq_subterm_inj_cond_subst[OF ** *]
            trmspairs_subst[of F "rm_vars (set X) θ"]
            subst_apply_pairs_pair_image_subst[of G "rm_vars (set X) θ"]
      by (metis (no_types, lifting) image_Un)
    thus ?thesis by simp
  qed
  thus ?thesis using NegChecks by simp
qed simp_all

lemma tfrsstp_all_wt_subst_apply:
  assumes S: "list_all tfrsstp S"
    and θ: "wtsubst θ" "wftrms (subst_range θ)" "bvarssst S  range_vars θ = {}"
  shows "list_all tfrsstp (S sst θ)"
proof -
  have "set (bvarssstp s)  range_vars θ = {}" when "s  set S" for s
    using that θ(3) unfolding bvarssst_def range_vars_alt_def by fastforce
  thus ?thesis
    using tfrsstp_subst[OF _ θ(1,2)] S
    unfolding list_all_iff
    by (auto simp add: subst_apply_stateful_strand_def)
qed

lemma trpairs_empty_case:
  assumes "trpairs F D = []"
  shows "D = []" "F  []"
proof -
  show "F  []" using assms by (auto intro: ccontr)

  have "trpairs F (a#A)  []" for a A
    by (induct F "a#A" rule: trpairs.induct) fastforce+
  thus "D = []" using assms by (cases D) simp_all
qed

lemma trpairs_elem_length_eq:
  assumes "G  set (trpairs F D)"
  shows "length G = length F" 
using assms by (induct F D arbitrary: G rule: trpairs.induct) auto

lemma trpairs_index:
  assumes "G  set (trpairs F D)" "i < length F"
  shows "d  set D. G ! i = (pair (F ! i), pair d)"
using assms
proof (induction F D arbitrary: i G rule: trpairs.induct)
  case (2 s t F D)
  obtain d G' where G:
      "d  set D" "G'  set (trpairs F D)"
      "G = (pair (s,t), pair d)#G'"
    using "2.prems"(1) by moura
  show ?case
    using "2.IH"[OF G(1,2)] "2.prems"(2) G(1,3)
    by (cases i) auto
qed simp

lemma trpairs_cons:
  assumes "G  set (trpairs F D)" "d  set D"
  shows "(pair (s,t), pair d)#G  set (trpairs ((s,t)#F) D)"
using assms by auto

lemma trpairs_has_pair_lists:
  assumes "G  set (trpairs F D)" "g  set G"
  shows "f  set F. d  set D. g = (pair f, pair d)"
using assms
proof (induction F D arbitrary: G rule: trpairs.induct)
  case (2 s t F D)
  obtain d G' where G:
      "d  set D" "G'  set (trpairs F D)"
      "G = (pair (s,t), pair d)#G'"
    using "2.prems"(1) by moura
  show ?case
    using "2.IH"[OF G(1,2)] "2.prems"(2) G(1,3)
    by (cases "g  set G'") auto
qed simp

lemma trpairs_is_pair_lists:
  assumes "f  set F" "d  set D"
  shows "G  set (trpairs F D). (pair f, pair d)  set G"
  (is "?P F D f d")
proof -
  have "f  set F. d  set D. ?P F D f d"
  proof (induction F D rule: trpairs.induct)
    case (2 s t F D)
    hence IH: "f  set F. d  set D. ?P F D f d" by metis
    moreover have "d  set D. ?P ((s,t)#F) D (s,t) d"
    proof
      fix d assume d: "d  set D"
      then obtain G where G: "G  set (trpairs F D)"
        using trpairs_empty_case(1) by force
      hence "(pair (s, t), pair d)#G  set (trpairs ((s,t)#F) D)"
        using d by auto
      thus "?P ((s,t)#F) D (s,t) d" using d G by auto
    qed
    ultimately show ?case by fastforce
  qed simp
  thus ?thesis by (metis assms)
qed

lemma trpairs_db_append_subset:
  "set (trpairs F D)  set (trpairs F (D@E))" (is ?A)
  "set (trpairs F E)  set (trpairs F (D@E))" (is ?B)
proof -
  show ?A
  proof (induction F D rule: trpairs.induct)
    case (2 s t F D)
    show ?case
    proof
      fix G assume "G  set (trpairs ((s,t)#F) D)"
      then obtain d G' where G':
          "d  set D" "G'  set (trpairs F D)" "G = (pair (s,t), pair d)#G'"
        by moura
      have "d  set (D@E)" "G'  set (trpairs F (D@E))" using "2.IH"[OF G'(1)] G'(1,2) by auto
      thus "G  set (trpairs ((s,t)#F) (D@E))" using G'(3) by auto
    qed
  qed simp

  show ?B
  proof (induction F E rule: trpairs.induct)
    case (2 s t F E)
    show ?case
    proof
      fix G assume "G  set (trpairs ((s,t)#F) E)"
      then obtain d G' where G':
          "d  set E" "G'  set (trpairs F E)" "G = (pair (s,t), pair d)#G'"
        by moura
      have "d  set (D@E)" "G'  set (trpairs F (D@E))" using "2.IH"[OF G'(1)] G'(1,2) by auto
      thus "G  set (trpairs ((s,t)#F) (D@E))" using G'(3) by auto
    qed
  qed simp
qed

lemma trpairs_trms_subset:
  "G  set (trpairs F D)  trmspairs G  pair ` set F  pair ` set D"
proof (induction F D arbitrary: G rule: trpairs.induct)
  case (2 s t F D G)
  obtain d G' where G:
      "d  set D" "G'  set (trpairs F D)" "G = (pair (s,t), pair d)#G'"
    using "2.prems"(1) by moura
 
  show ?case using "2.IH"[OF G(1,2)] G(1,3) by auto
qed simp

lemma trpairs_trms_subset':
  "(trmspairs ` set (trpairs F D))  pair ` set F  pair ` set D"
using trpairs_trms_subset by blast

lemma tr_trms_subset:
  "A'  set (tr A D)  trmsst A'  trmssst A  pair ` setopssst A  pair ` set D"
proof (induction A D arbitrary: A' rule: tr.induct)
  case 1 thus ?case by simp
next
  case (2 t A D)
  then obtain A'' where A'': "A' = send⟨tst#A''" "A''  set (tr A D)" by moura
  hence "trmsst A''  trmssst A  pair ` setopssst A  pair ` set D" by (metis "2.IH")
  thus ?case using A'' by (auto simp add: setopssst_def)
next
  case (3 t A D)
  then obtain A'' where A'': "A' = receive⟨tst#A''" "A''  set (tr A D)" by moura
  hence "trmsst A''  trmssst A  pair ` setopssst A  pair ` set D" by (metis "3.IH")
  thus ?case using A'' by (auto simp add: setopssst_def)
next
  case (4 ac t t' A D)
  then obtain A'' where A'': "A' = ac: t  t'st#A''" "A''  set (tr A D)" by moura
  hence "trmsst A''  trmssst A  pair ` setopssst A  pair ` set D" by (metis "4.IH")
  thus ?case using A'' by (auto simp add: setopssst_def)
next
  case (5 t s A D)
  hence "A'  set (tr A (List.insert (t,s) D))" by simp
  hence "trmsst A'  trmssst A  pair ` setopssst A  pair ` set (List.insert (t, s) D)"
    by (metis "5.IH")
  thus ?case by (auto simp add: setopssst_def)
next
  case (6 t s A D)
  from 6 obtain Di A'' B C where A'':
      "Di  set (subseqs D)" "A''  set (tr A [dD. d  set Di])" "A' = (B@C)@A''"
      "B = map (λd. check: (pair (t,s))  (pair d)st) Di"
      "C = map (λd. Inequality [] [(pair (t,s) , pair d)]) [dD. d  set Di]"
    by moura
  hence "trmsst A''  trmssst A  pair ` setopssst A  pair ` set [dD. d  set Di]"
    by (metis "6.IH")
  hence "trmsst A''  trmssst (Delete t s#A)  pair ` setopssst (Delete t s#A)  pair ` set D"
    by (auto simp add: setopssst_def)
  moreover have "trmsst (B@C)  insert (pair (t,s)) (pair ` set D)"
    using A''(4,5) subseqs_set_subset[OF A''(1)] by auto
  moreover have "pair (t,s)  pair ` setopssst (Delete t s#A)" by (simp add: setopssst_def)
  ultimately show ?case using A''(3) trmsst_append[of "B@C" A'] by auto
next
  case (7 ac t s A D)
  from 7 obtain d A'' where A'':
      "d  set D" "A''  set (tr A D)"
      "A' = ac: (pair (t,s))  (pair d)st#A''"
    by moura
  hence "trmsst A''  trmssst A  pair ` setopssst A  pair ` set D" by (metis "7.IH")
  moreover have "trmsst A' = {pair (t,s), pair d}  trmsst A''"
    using A''(1,3) by auto
  ultimately show ?case using A''(1) by (auto simp add: setopssst_def)
next
  case (8 X F F' A D)
  from 8 obtain A'' where A'':
      "A''  set (tr A D)" "A' = (map (λG. X⟨∨≠: (F@G)st) (trpairs F' D))@A''"
    by moura

  define B where "B  (trmspairs ` set (trpairs F' D))"

  have "trmsst A''  trmssst A  pair ` setopssst A  pair ` set D" by (metis A''(1) "8.IH")
  hence "trmsst A'  B  trmspairs F  trmssst A  pair ` setopssst A  pair ` set D"
    using A'' B_def by auto
  moreover have "B  pair ` set F'  pair ` set D"
    using trpairs_trms_subset'[of F' D] B_def by simp
  moreover have "pair ` setopssst (X⟨∨≠: F ∨∉: F'#A) = pair ` set F'  pair ` setopssst A"
    by (auto simp add: setopssst_def)
  ultimately show ?case by auto
qed

lemma trpairs_vars_subset:
  "G  set (trpairs F D)  fvpairs G  fvpairs F  fvpairs D"
proof (induction F D arbitrary: G rule: trpairs.induct)
  case (2 s t F D G)
  obtain d G' where G:
      "d  set D" "G'  set (trpairs F D)" "G = (pair (s,t), pair d)#G'"
    using "2.prems"(1) by moura
 
  show ?case using "2.IH"[OF G(1,2)] G(1,3) unfolding pair_def by auto
qed simp

lemma trpairs_vars_subset': "(fvpairs ` set (trpairs F D))  fvpairs F  fvpairs D"
using trpairs_vars_subset[of _ F D] by blast

lemma tr_vars_subset:
  assumes "A'  set (tr A D)"
  shows "fvst A'  fvsst A  ((t,t')  set D. fv t  fv t')" (is ?P)
  and "bvarsst A'  bvarssst A" (is ?Q)
proof -
  show ?P using assms
  proof (induction A arbitrary: A' D rule: strand_sem_stateful_induct)
    case (ConsIn A' D ac t s A)
    then obtain A'' d where *:
        "d  set D" "A' = ac: (pair (t,s))  (pair d)st#A''"
        "A''  set (tr A D)"
      by moura
    hence "fvst A''  fvsst A  ((t,t')set D. fv t  fv t')" by (metis ConsIn.IH)
    thus ?case using * unfolding pair_def by auto
  next
    case (ConsDel A' D t s A)
    define Dfv where "Dfv  λD::('fun,'var) dbstatelist. ((t,t')set D. fv t  fv t')"
    define fltD where "fltD  λDi. filter (λd. d  set Di) D"
    define constr where
      "constr  λDi. (map (λd. check: (pair (t,s))  (pair d)st) Di)@
                      (map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) (fltD Di))"
    from ConsDel obtain A'' Di where *:
        "Di  set (subseqs D)" "A' = (constr Di)@A''" "A''  set (tr A (fltD Di))"
      unfolding constr_def fltD_def by moura
    hence "fvst A''  fvsst A  Dfv (fltD Di)"
      unfolding Dfv_def constr_def fltD_def by (metis ConsDel.IH)
    moreover have "Dfv (fltD Di)  Dfv D" unfolding Dfv_def constr_def fltD_def by auto
    moreover have "Dfv Di  Dfv D"
      using subseqs_set_subset(1)[OF *(1)] unfolding Dfv_def constr_def fltD_def by fast
    moreover have "fvst (constr Di)  fv t  fv s  (Dfv Di  Dfv (fltD Di))"
      unfolding Dfv_def constr_def fltD_def pair_def by auto
    moreover have "fvsst (Delete t s#A) = fv t  fv s  fvsst A" by auto
    moreover have "fvst A' = fvst (constr Di)  fvst A''" using * by force
    ultimately have "fvst A'  fvsst (Delete t s#A)  Dfv D" by auto
    thus ?case unfolding Dfv_def fltD_def constr_def by simp
  next
    case (ConsNegChecks A' D X F F' A)
    then obtain A'' where A'':
        "A''  set (tr A D)" "A' = (map (λG. X⟨∨≠: (F@G)st) (trpairs F' D))@A''"
      by moura

    define B where "B  (fvpairs ` set (trpairs F' D))"

    have 1: "fvst (map (λG. X⟨∨≠: (F@G)st) (trpairs F' D))  (B  fvpairs F) - set X"
      unfolding B_def by auto

    have 2: "B  fvpairs F'  fvpairs D"
      using trpairs_vars_subset'[of F' D]
      unfolding B_def by simp

    have "fvst A'  ((fvpairs F'  fvpairs D  fvpairs F) - set X)  fvst A''"
      using 1 2 A''(2) by fastforce
    thus ?case using ConsNegChecks.IH[OF A''(1)] by auto
  qed fastforce+

  show ?Q using assms by (induct A arbitrary: A' D rule: strand_sem_stateful_induct) fastforce+
qed

lemma tr_vars_disj:
  assumes "A'  set (tr A D)" "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
  and "fvsst A  bvarssst A = {}"
  shows "fvst A'  bvarsst A' = {}"
  using assms tr_vars_subset by fast

lemma wf_fun_pair_ineqs_map:
  assumes "wfst X A"
  shows "wfst X (map (λd. Y⟨∨≠: [(pair (t, s), pair d)]st) D@A)"
using assms by (induct D) auto

lemma wf_fun_pair_negchecks_map:
  assumes "wfst X A"
  shows "wfst X (map (λG. Y⟨∨≠: (F@G)st) M@A)"
using assms by (induct M) auto

lemma wf_fun_pair_eqs_ineqs_map:
  fixes A::"('fun,'var) strand"
  assumes "wfst X A" "Di  set (subseqs D)" "(t,t')  set D. fv t  fv t'  X"
  shows "wfst X ((map (λd. check: (pair (t,s))  (pair d)st) Di)@
                 (map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di])@A)"
proof -
  let ?c1 = "map (λd. check: (pair (t,s))  (pair d)st) Di"
  let ?c2 = "map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di]"
  have 1: "wfst X (?c2@A)" using wf_fun_pair_ineqs_map[OF assms(1)] by simp
  have 2: "(t,t')  set Di. fv t  fv t'  X" 
    using assms(2,3) by (meson contra_subsetD subseqs_set_subset(1))
  have "wfst X (?c1@B)" when "wfst X B" for B::"('fun,'var) strand"
    using 2 that by (induct Di) auto
  thus ?thesis using 1 by simp
qed

lemma trmssst_wt_subst_ex:
  assumes θ: "wtsubst θ" "wftrms (subst_range θ)"
    and t: "t  trmssst (S sst θ)"
  shows "s δ. s  trmssst S  wtsubst δ  wftrms (subst_range δ)  t = s  δ"
using t
proof (induction S)
  case (Cons s S) thus ?case
  proof (cases "t  trmssst (S sst θ)")
    case False
    hence "t  trmssstp (s sstp θ)"
      using Cons.prems trmssst_subst_cons[of s S θ]
      by auto
    then obtain u where u: "u  trmssstp s" "t = u  rm_vars (set (bvarssstp s)) θ"
      using trmssstp_subst'' by blast
    thus ?thesis
      using trmssst_subst_cons[of s S θ]
            wt_subst_rm_vars[OF θ(1), of "set (bvarssstp s)"]
            wf_trms_subst_rm_vars'[OF θ(2), of "set (bvarssstp s)"]
      by fastforce
  qed auto
qed simp

lemma setopssst_wt_subst_ex:
  assumes θ: "wtsubst θ" "wftrms (subst_range θ)"
    and t: "t  pair ` setopssst (S sst θ)"
  shows "s δ. s  pair ` setopssst S  wtsubst δ  wftrms (subst_range δ)  t = s  δ"
using t
proof (induction S)
  case (Cons x S) thus ?case
  proof (cases x)
    case (Insert t' s)
    hence "t = pair (t',s)  θ  t  pair ` setopssst (S sst θ)"
      using Cons.prems subst_sst_cons[of _ S θ]
      unfolding pair_def by (force simp add: setopssst_def)
    thus ?thesis
      using Insert Cons.IH θ by (cases "t = pair (t', s)  θ") (fastforce, auto)
  next
    case (Delete t' s)
    hence "t = pair (t',s)  θ  t  pair ` setopssst (S sst θ)"
      using Cons.prems subst_sst_cons[of _ S θ]
      unfolding pair_def by (force simp add: setopssst_def)
    thus ?thesis
      using Delete Cons.IH θ by (cases "t = pair (t', s)  θ") (fastforce, auto)
  next
    case (InSet ac t' s)
    hence "t = pair (t',s)  θ  t  pair ` setopssst (S sst θ)"
      using Cons.prems subst_sst_cons[of _ S θ]
      unfolding pair_def by (force simp add: setopssst_def)
    thus ?thesis
      using InSet Cons.IH θ by (cases "t = pair (t', s)  θ") (fastforce, auto)
  next
    case (NegChecks X F F')
    hence "t  pair ` set (F' pairs rm_vars (set X) θ)  t  pair ` setopssst (S sst θ)"
      using Cons.prems subst_sst_cons[of _ S θ]
      unfolding pair_def by (force simp add: setopssst_def)
    thus ?thesis
    proof
      assume "t  pair ` set (F' pairs rm_vars (set X) θ)"
      then obtain s where s: "t = s  rm_vars (set X) θ" "s  pair ` set F'"
        using subst_apply_pairs_pair_image_subst[of F' "rm_vars (set X) θ"] by auto
      thus ?thesis
        using NegChecks setopssst_pair_image_cons(8)[of X F F' S]
              wt_subst_rm_vars[OF θ(1), of "set X"]
              wf_trms_subst_rm_vars'[OF θ(2), of "set X"]
        by fast
    qed (use Cons.IH in auto)
  qed (auto simp add: setopssst_def subst_sst_cons[of _ S θ])
qed (simp add: setopssst_def)

lemma setopssst_wftrms:
  "wftrms (trmssst A)  wftrms (pair ` setopssst A)"
  "wftrms (trmssst A)  wftrms (trmssst A  pair ` setopssst A)"
proof -
  show "wftrms (trmssst A)  wftrms (pair ` setopssst A)"
  proof (induction A)
    case (Cons a A)
    hence 0: "wftrms (trmssstp a)" "wftrms (pair ` setopssst A)" by auto
    thus ?case
    proof (cases a)
      case (NegChecks X F F')
      hence "wftrms (trmspairs F')" using 0 by simp
      thus ?thesis using NegChecks wftrms_pairs[of F'] 0 by (auto simp add: setopssst_def)
    qed (auto simp add: setopssst_def dest: fun_pair_wftrm)
  qed (auto simp add: setopssst_def)
  thus "wftrms (trmssst A)  wftrms (trmssst A  pair ` setopssst A)" by fast
qed

lemma SMP_MP_split:
  assumes "t  SMP M"
    and M: "m  M. is_Fun m"
  shows "(δ. wtsubst δ  wftrms (subst_range δ)  t  M set δ) 
         t  SMP ((subtermsset M  ((set  fst  Ana) ` M)) - M)"
  (is "?P t  ?Q t")
using assms(1)
proof (induction t rule: SMP.induct)
  case (MP t)
  have "wtsubst Var" "wftrms (subst_range Var)" "M set Var = M" by simp_all
  thus ?case using MP by metis
next
  case (Subterm t t')
  show ?case using Subterm.IH
  proof
    assume "?P t"
    then obtain s δ where s: "s  M" "t = s  δ" and δ: "wtsubst δ" "wftrms (subst_range δ)" by moura
    then obtain f T where fT: "s = Fun f T" using M by fast

    have "(s'. s'  s  t' = s'  δ)  (x  fv s. t'  δ x)"
      using subterm_subst_unfold[OF Subterm.hyps(2)[unfolded s(2)]] by blast
    thus ?thesis
    proof
      assume "s'. s'  s  t' = s'  δ"
      then obtain s' where s': "s'  s" "t' = s'  δ" by moura
      show ?thesis
      proof (cases "s'  M")
        case True thus ?thesis using s' δ by blast
      next
        case False
        hence "s'  (subtermsset M  ((set  fst  Ana) ` M)) - M" using s'(1) s(1) by force
        thus ?thesis using SMP.Substitution[OF SMP.MP[of s'] δ] s' by presburger
      qed
    next
      assume "x  fv s. t'  δ x"
      then obtain x where x: "x  fv s" "t'  δ x" by moura
      have "Var x  M" using M by blast
      hence "Var x  (subtermsset M  ((set  fst  Ana) ` M)) - M"
        using s(1) var_is_subterm[OF x(1)] by blast
      hence "δ x  SMP ((subtermsset M  ((set  fst  Ana) ` M)) - M)"
        using SMP.Substitution[OF SMP.MP[of "Var x"] δ] by auto
      thus ?thesis using SMP.Subterm x(2) by presburger
    qed
  qed (metis SMP.Subterm[OF _ Subterm.hyps(2)])
next
  case (Substitution t δ)
  show ?case using Substitution.IH
  proof
    assume "?P t"
    then obtain θ where "wtsubst θ" "wftrms (subst_range θ)" "t  M set θ" by moura
    hence "wtsubst (θ s δ)" "wftrms (subst_range (θ s δ))" "t  δ  M set (θ s δ)"
      using wt_subst_compose[of θ, OF _ Substitution.hyps(2)]
            wf_trm_subst_compose[of θ _ δ, OF _ wf_trm_subst_rangeD[OF Substitution.hyps(3)]]
            wf_trm_subst_range_iff
      by (argo, blast, auto)
    thus ?thesis by blast
  next
    assume "?Q t" thus ?thesis using SMP.Substitution[OF _ Substitution.hyps(2,3)] by meson
  qed
next
  case (Ana t K T k)
  show ?case using Ana.IH
  proof
    assume "?P t"
    then obtain θ where θ: "wtsubst θ" "wftrms (subst_range θ)" "t  M set θ" by moura
    then obtain s where s: "s  M" "t = s  θ" by auto
    then obtain f S where fT: "s = Fun f S" using M by (cases s) auto
    obtain K' T' where s_Ana: "Ana s = (K', T')" by (metis surj_pair)
    hence "set K = set K' set θ" "set T = set T' set θ"
      using Ana_subst'[of f S K' T'] fT Ana.hyps(2) s(2) by auto
    then obtain k' where k': "k'  set K'" "k = k'  θ" using Ana.hyps(3) by fast
    show ?thesis
    proof (cases "k'  M")
      case True thus ?thesis using k' θ(1,2) by blast
    next
      case False
      hence "k'  (subtermsset M  ((set  fst  Ana) ` M)) - M" using k'(1) s_Ana s(1) by force
      thus ?thesis using SMP.Substitution[OF SMP.MP[of k'] θ(1,2)] k'(2) by presburger
    qed
  next
    assume "?Q t" thus ?thesis using SMP.Ana[OF _ Ana.hyps(2,3)] by meson
  qed
qed

lemma setops_subterm_trms:
  assumes t: "t  pair ` setopssst S"
    and s: "s  t"
  shows "s  subtermsset (trmssst S)"
proof -
  obtain u u' where u: "pair (u,u')  pair ` setopssst S" "t = pair (u,u')"
    using t setopssst_are_pairs[of _ S] by blast
  hence "s  u  s  u'" using s unfolding pair_def by auto
  thus ?thesis using u setopssst_member_iff[of u u' S] unfolding trmssst_def by force
qed

lemma setops_subterms_cases:
  assumes t: "t  subtermsset (pair ` setopssst S)"
  shows "t  subtermsset (trmssst S)  t  pair ` setopssst S"
proof -
  obtain s s' where s: "pair (s,s')  pair ` setopssst S" "t  pair (s,s')"
    using t setopssst_are_pairs[of _ S] by blast
  hence "t  pair ` setopssst S  t  s  t  s'" unfolding pair_def by auto
  thus ?thesis using s setopssst_member_iff[of s s' S] unfolding trmssst_def by force
qed

lemma setops_SMP_cases:
  assumes "t  SMP (pair ` setopssst S)"
    and "p. Ana (pair p) = ([], [])"
  shows "(δ. wtsubst δ  wftrms (subst_range δ)  t  pair ` setopssst S set δ)  t  SMP (trmssst S)"
proof -
  have 0: "((set  fst  Ana) ` pair ` setopssst S) = {}"
  proof (induction S)
    case (Cons x S) thus ?case
      using assms(2) by (cases x) (auto simp add: setopssst_def)
  qed (simp add: setopssst_def)
  
  have 1: "m  pair ` setopssst S. is_Fun m"
  proof (induction S)
    case (Cons x S) thus ?case
      unfolding pair_def by (cases x) (auto simp add: assms(2) setopssst_def)
  qed (simp add: setopssst_def)

  have 2:
      "subtermsset (pair ` setopssst S) 
       ((set  fst  Ana) ` (pair ` setopssst S)) - pair ` setopssst S
         subtermsset (trmssst S)"
    using 0 setops_subterms_cases by fast

  show ?thesis
    using SMP_MP_split[OF assms(1) 1] SMP_mono[OF 2] SMP_subterms_eq[of "trmssst S"]
    by blast
qed

lemma tfr_setops_if_tfr_trms:
  assumes "Pair  (funs_term ` SMP (trmssst S))"
    and "p. Ana (pair p) = ([], [])"
    and "s  pair ` setopssst S. t  pair ` setopssst S. (δ. Unifier δ s t)  Γ s = Γ t"
    and "s  pair ` setopssst S. t  pair ` setopssst S.
          (σ θ ρ. wtsubst σ  wtsubst θ  wftrms (subst_range σ)  wftrms (subst_range θ) 
                   Unifier ρ (s  σ) (t  θ))
           (δ. Unifier δ s t)"
    and tfr: "tfrset (trmssst S)"
  shows "tfrset (trmssst S  pair ` setopssst S)"
proof -
  have 0: "t  SMP (trmssst S) - range Var  t  SMP (pair ` setopssst S) - range Var"
    when "t  SMP (trmssst S  pair ` setopssst S) - range Var" for t
    using that SMP_union by blast

  have 1: "s  SMP (trmssst S) - range Var"
      when st: "s  SMP (pair ` setopssst S) - range Var"
               "t  SMP (trmssst S) - range Var"
               "δ. Unifier δ s t"
         for s t
  proof -
    have "(δ. s  pair ` setopssst S set δ)  s  SMP (trmssst S) - range Var"
      using st setops_SMP_cases[of s S] assms(2) by blast
    moreover {
      fix δ assume δ: "s  pair ` setopssst S set δ"
      then obtain s' where s': "s'  pair ` setopssst S" "s = s'  δ" by blast
      then obtain u u' where u: "s' = Fun Pair [u,u']"
        using setopssst_are_pairs[of s'] unfolding pair_def by fast
      hence *: "s = Fun Pair [u  δ, u'  δ]" using δ s' by simp

      obtain f T where fT: "t = Fun f T" using st(2) by (cases t) auto
      hence "f  Pair" using st(2) assms(1) by auto
      hence False using st(3) * fT s' u by fast
    } ultimately show ?thesis by meson
  qed
  
  have 2: "Γ s = Γ t"
      when "s  SMP (trmssst S) - range Var"
           "t  SMP (trmssst S) - range Var"
           "δ. Unifier δ s t"
       for s t
    using that tfr unfolding tfrset_def by blast
  
  have 3: "Γ s = Γ t"
      when st: "s  SMP (pair ` setopssst S) - range Var"
               "t  SMP (pair ` setopssst S) - range Var"
               "δ. Unifier δ s t"
      for s t
  proof -
    let ?P = "λs δ. wtsubst δ  wftrms (subst_range δ)  s  pair ` setopssst S set δ"
    have "(δ. ?P s δ)  s  SMP (trmssst S) - range Var"
         "(δ. ?P t δ)  t  SMP (trmssst S) - range Var"
      using setops_SMP_cases[of _ S] assms(2) st(1,2) by auto
    hence "(δ δ'. ?P s δ  ?P t δ')  Γ s = Γ t" by (metis 1 2 st)
    moreover {
      fix δ δ' assume *: "?P s δ" "?P t δ'"
      then obtain s' t' where **:
          "s'  pair ` setopssst S" "t'  pair ` setopssst S" "s = s'  δ" "t = t'  δ'"
        by blast
      hence "θ. Unifier θ s' t'" using st(3) assms(4) * by blast
      hence "Γ s' = Γ t'" using assms(3) ** by blast
      hence "Γ s = Γ t" using * **(3,4) wt_subst_trm''[of δ s'] wt_subst_trm''[of δ' t'] by argo
    } ultimately show ?thesis by blast
  qed
  
  show ?thesis using 0 1 2 3 unfolding tfrset_def by metis
qed


subsection ‹The Typing Result for Stateful Constraints›
context
begin
private lemma tr_wf':
  assumes "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
  and "(t,t')  set D. fv t  fv t'  X"
  and "wf'sst X A" "fvsst A  bvarssst A = {}"
  and "A'  set (tr A D)"
  shows "wfst X A'"
proof -
  define P where
    "P = (λ(D::('fun,'var) dbstatelist) (A::('fun,'var) stateful_strand).
          ((t,t')  set D. (fv t  fv t')  bvarssst A = {})  fvsst A  bvarssst A = {})"

  have "P D A" using assms(1,4) by (simp add: P_def)
  with assms(5,3,2) show ?thesis
  proof (induction A arbitrary: A' D X rule: wf'sst.induct)
    case 1 thus ?case by simp
  next
    case (2 X t A A')
    then obtain A'' where A'': "A' = receive⟨tst#A''" "A''  set (tr A D)" "fv t  X"
      by moura
    have *: "wf'sst X A" "(s,s')  set D. fv s  fv s'  X" "P D A"
      using 2(1,2,3,4) apply (force, force)
      using 2(5) unfolding P_def by force
    show ?case using "2.IH"[OF A''(2) *] A''(1,3) by simp
  next
    case (3 X t A A')
    then obtain A'' where A'': "A' = send⟨tst#A''" "A''  set (tr A D)"
      by moura
    have *: "wf'sst (X  fv t) A" "(s,s')  set D. fv s  fv s'  X  fv t" "P D A"
      using 3(1,2,3,4) apply (force, force)
      using 3(5) unfolding P_def by force
    show ?case using "3.IH"[OF A''(2) *] A''(1) by simp
  next
    case (4 X t t' A A')
    then obtain A'' where A'': "A' = assign: t  t'st#A''" "A''  set (tr A D)" "fv t'  X"
      by moura
    have *: "wf'sst (X  fv t) A" "(s,s')  set D. fv s  fv s'  X  fv t" "P D A"
      using 4(1,2,3,4) apply (force, force)
      using 4(5) unfolding P_def by force
    show ?case using "4.IH"[OF A''(2) *] A''(1,3) by simp
  next
    case (5 X t t' A A')
    then obtain A'' where A'': "A' = check: t  t'st#A''" "A''  set (tr A D)"
      by moura
    have *: "wf'sst X A" "P D A"
      using 5(3) apply force
      using 5(5) unfolding P_def by force
    show ?case using "5.IH"[OF A''(2) *(1) 5(4) *(2)] A''(1) by simp
  next
    case (6 X t s A A')
    hence A': "A'  set (tr A (List.insert (t,s) D))" "fv t  X" "fv s  X" by auto
    have *: "wf'sst X A" "(s,s')  set (List.insert (t,s) D). fv s  fv s'  X" using 6 by auto
    have **: "P (List.insert (t,s) D) A" using 6(5) unfolding P_def by force
    show ?case using "6.IH"[OF A'(1) * **] A'(2,3) by simp
  next
    case (7 X t s A A')
    let ?constr = "λDi. (map (λd. check: (pair (t,s))  (pair d)st) Di)@
                        (map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di])"
    from 7 obtain Di A'' where A'':
        "A' = ?constr Di@A''" "A''  set (tr A [dD. d  set Di])"
        "Di  set (subseqs D)"
      by moura
    have *: "wf'sst X A" "(t',s')  set [dD. d  set Di]. fv t'  fv s'  X"
      using 7 by auto
    have **: "P [dD. d  set Di] A" using 7 unfolding P_def by force
    have ***: "(t, t')  set D. fv t  fv t'  X" using 7 by auto
    show ?case
      using "7.IH"[OF A''(2) * **] A''(1) wf_fun_pair_eqs_ineqs_map[OF _ A''(3) ***]
      by simp
  next
    case (8 X t s A A')
    then obtain d A'' where A'':
        "A' = assign: (pair (t,s))  (pair d)st#A''"
        "A''  set (tr A D)" "d  set D"
      by moura
    have *: "wf'sst (X  fv t  fv s) A" "(t',s')set D. fv t'  fv s'  X  fv t  fv s" "P D A"
      using 8(1,2,3,4) apply (force, force)
      using 8(5) unfolding P_def by force
    have **: "fv (pair d)  X" using A''(3) "8.prems"(3) unfolding pair_def by fastforce
    have ***: "fv (pair (t,s)) = fv s  fv t" unfolding pair_def by auto
    show ?case using "8.IH"[OF A''(2) *] A''(1) ** *** unfolding pair_def by (simp add: Un_assoc)
  next
    case (9 X t s A A')
    then obtain d A'' where A'':
        "A' = check: (pair (t,s))  (pair d)st#A''"
        "A''  set (tr A D)" "d  set D"
      by moura
    have *: "wf'sst X A""P D A"
      using 9(3) apply force
      using 9(5) unfolding P_def by force
    have **: "fv (pair d)  X" using A''(3) "9.prems"(3) unfolding pair_def by fastforce
    have ***: "fv (pair (t,s)) = fv s  fv t" unfolding pair_def by auto
    show ?case using "9.IH"[OF A''(2) *(1) 9(4) *(2)] A''(1) ** *** by (simp add: Un_assoc)
  next
    case (10 X Y F F' A A')
    from 10 obtain A'' where A'':
        "A' = (map (λG. Y⟨∨≠: (F@G)st) (trpairs F' D))@A''" "A''  set (tr A D)"
      by moura

    have *: "wf'sst X A" "(t',s')  set D. fv t'  fv s'  X" using 10 by auto
    
    have "bvarssst A  bvarssst (Y⟨∨≠: F ∨∉: F'#A)" "fvsst A  fvsst (Y⟨∨≠: F ∨∉: F'#A)" by auto
    hence **:  "P D A" using 10 unfolding P_def by blast

    show ?case using "10.IH"[OF A''(2) * **] A''(1) wf_fun_pair_negchecks_map by simp
  qed
qed

private lemma tr_wftrms:
  assumes "A'  set (tr A [])" "wftrms (trmssst A)"
  shows "wftrms (trmsst A')"
using tr_trms_subset[OF assms(1)] setopssst_wftrms(2)[OF assms(2)]
by auto

lemma tr_wf:
  assumes "A'  set (tr A [])"
    and "wfsst A"
    and "wftrms (trmssst A)" 
  shows "wfst {} A'"
    and "wftrms (trmsst A')"
    and "fvst A'  bvarsst A' = {}"
using tr_wf'[OF _ _ _ _ assms(1)]
      tr_wftrms[OF assms(1,3)]
      tr_vars_disj[OF assms(1)]
      assms(2)
by fastforce+

private lemma tr_tfrsstp:
  assumes "A'  set (tr A D)" "list_all tfrsstp A"
  and "fvsst A  bvarssst A = {}" (is "?P0 A D")
  and "(t,s)  set D. (fv t  fv s)  bvarssst A = {}" (is "?P1 A D")
  and "t  pair ` setopssst A  pair ` set D. t'  pair ` setopssst A  pair ` set D.
          (δ. Unifier δ t t')  Γ t = Γ t'" (is "?P3 A D")
  shows "list_all tfrstp A'"
proof -
  have sublmm: "list_all tfrsstp A" "?P0 A D" "?P1 A D" "?P3 A D"
    when p: "list_all tfrsstp (a#A)" "?P0 (a#A) D" "?P1 (a#A) D" "?P3 (a#A) D"
    for a A D
    using p(1) apply (simp add: tfrsst_def)
    using p(2) fvsst_cons_subset bvarssst_cons_subset apply fast
    using p(3) bvarssst_cons_subset apply fast
    using p(4) setopssst_cons_subset by fast

  show ?thesis using assms
  proof (induction A D arbitrary: A' rule: tr.induct)
    case 1 thus ?case by simp
  next
    case (2 t A D)
    note prems = "2.prems"
    note IH = "2.IH"
    from prems(1) obtain A'' where A'': "A' = send⟨tst#A''" "A''  set (tr A D)"
      by moura
    have "list_all tfrstp A''" using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] by meson
    thus ?case using A''(1) by simp
  next
    case (3 t A D)
    note prems = "3.prems"
    note IH = "3.IH"
    from prems(1) obtain A'' where A'': "A' = receive⟨tst#A''" "A''  set (tr A D)"
      by moura
    have "list_all tfrstp A''" using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] by meson
    thus ?case using A''(1) by simp
  next
    case (4 ac t t' A D)
    note prems = "4.prems"
    note IH = "4.IH"
    from prems(1) obtain A'' where A'':
        "A' = ac: t  t'st#A''" "A''  set (tr A D)"
      by moura
    have "list_all tfrstp A''" using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] by meson
    moreover have "(δ. Unifier δ t t')  Γ t = Γ t'" using prems(2) by (simp add: tfrsst_def)
    ultimately show ?case using A''(1) by auto
  next
    case (5 t s A D)
    note prems = "5.prems"
    note IH = "5.IH"
    from prems(1) have A': "A'  set (tr A (List.insert (t,s) D))" by simp
  
    have 1: "list_all tfrsstp A" using sublmm[OF prems(2,3,4,5)] by simp
  
    have "pair ` setopssst (Insert t s#A)  pair`set D =
          pair ` setopssst A  pair`set (List.insert (t,s) D)"
      by (simp add: setopssst_def)
    hence 3: "?P3 A (List.insert (t,s) D)" using prems(5) by metis
    moreover have "?P1 A (List.insert (t, s) D)" using prems(3,4) bvarssst_cons_subset[of A] by auto
    ultimately have "list_all tfrstp A'" using IH[OF A' sublmm(1,2)[OF prems(2,3,4,5)] _ 3] by metis
    thus ?case using A'(1) by auto
  next
    case (6 t s A D)
    note prems = "6.prems"
    note IH = "6.IH"
    
    define constr where constr:
      "constr  (λDi. (map (λd. check: (pair (t,s))  (pair d)st) Di)@
                       (map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di]))"
    
    from prems(1) obtain Di A'' where A'':
        "A' = constr Di@A''" "A''  set (tr A [dD. d  set Di])"
        "Di  set (subseqs D)"
      unfolding constr by auto
  
    define Q1 where "Q1  (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
        x  (fvpairs F) - set X. a. Γ (Var x) = TAtom a)"

    define Q2 where "Q2  (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
        f T. Fun f T  subtermsset (trmspairs F)  T = []  (s  set T. s  Var ` set X))"
  
    have "set [dD. d  set Di]  set D"
         "pair ` setopssst A  pair ` set [dD. d  set Di]
           pair ` setopssst (Delete t s#A)  pair ` set D"
      by (auto simp add: setopssst_def)
    hence *: "?P3 A [dD. d  set Di]" using prems(5) by blast
    have **: "?P1 A [dD. d  set Di]" using prems(4,5) by auto
    have 1: "list_all tfrstp A''"
      using IH[OF A''(3,2) sublmm(1,2)[OF prems(2,3,4,5)] ** *]
      by metis
  
    have 2: "ac: u  u'st  set A'' 
             (d  set Di. u = pair (t,s)  u' = pair d)"
      when "ac: u  u'st  set A'" for ac u u'
      using that A''(1) unfolding constr by force
    have 3: "Inequality X U  set A'  Inequality X U  set A'' 
             (d  set [dD. d  set Di].
                U = [(pair (t,s), pair d)]  Q2 [(pair (t,s), pair d)] X)"
        for X U
      using A''(1) unfolding Q2_def constr by force
    have 4:
        "dset D. (δ. Unifier δ (pair (t,s)) (pair d))  Γ (pair (t,s)) = Γ (pair d)"
      using prems(5) by (simp add: setopssst_def)
  
    { fix ac u u'
      assume a: "ac: u  u'st  set A'" "δ. Unifier δ u u'"
      hence "ac: u  u'st  set A''  (d  set Di. u = pair (t,s)  u' = pair d)"
        using 2 by metis
      hence "Γ u = Γ u'"
        using 1(1) 4 subseqs_set_subset[OF A''(3)] a(2) tfrstp_list_all_alt_def[of A'']
        by blast
    } moreover {
      fix u U
      assume "U⟨∨≠: ust  set A'"
      hence "U⟨∨≠: ust  set A'' 
             (d  set [dD. d  set Di]. u = [(pair (t,s), pair d)]  Q2 u U)"
        using 3 by metis
      hence "Q1 u U  Q2 u U"
        using 1 4 subseqs_set_subset[OF A''(3)] tfrstp_list_all_alt_def[of A'']
        unfolding Q1_def Q2_def
        by blast
    } ultimately show ?case using tfrstp_list_all_alt_def[of A'] unfolding Q1_def Q2_def by blast
  next
    case (7 ac t s A D)
    note prems = "7.prems"
    note IH = "7.IH"

    from prems(1) obtain d A'' where A'':
        "A' = ac: (pair (t,s))  (pair d)st#A''"
        "A''  set (tr A D)" "d  set D"
      by moura

    have "list_all tfrstp A''"
      using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]]
      by metis
    moreover have "(δ. Unifier δ (pair (t,s)) (pair d))  Γ (pair (t,s)) = Γ (pair d)"
      using prems(2,5) A''(3) unfolding tfrsst_def by (simp add: setopssst_def)
    ultimately show ?case using A''(1) by fastforce
  next
    case (8 X F F' A D)
    note prems = "8.prems"
    note IH = "8.IH"

    define constr where "constr = (map (λG. X⟨∨≠: (F@G)st) (trpairs F' D))"

    define Q1 where "Q1  (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
        x  (fvpairs F) - set X. a. Γ (Var x) = TAtom a)"

    define Q2 where "Q2  (λ(M::('fun,'var) terms) X.
        f T. Fun f T  subtermsset M  T = []  (s  set T. s  Var ` set X))"

    have Q2_subset: "Q2 M' X" when "M'  M" "Q2 M X" for X M M'
      using that unfolding Q2_def by auto

    have Q2_supset: "Q2 (M  M') X" when "Q2 M X" "Q2 M' X" for X M M'
      using that unfolding Q2_def by auto

    from prems(1) obtain A'' where A'': "A' = constr@A''" "A''  set (tr A D)"
      using constr_def by moura

    have 0: "F' = []  constr = [X⟨∨≠: Fst]" unfolding constr_def by simp

    have 1: "list_all tfrstp A''"
      using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]]
      by metis

    have 2: "(F' = []  Q1 F X)  Q2 (trmspairs F  pair ` set F') X"
      using prems(2) unfolding Q1_def Q2_def by simp
  
    have 3: "list_all tfrstp constr" when "F' = []" "Q1 F X"
      using that 0 2 tfrstp_list_all_alt_def[of constr] unfolding Q1_def by auto

    { fix c assume "c  set constr"
      hence "G  set (trpairs F' D). c = X⟨∨≠: (F@G)st" unfolding constr_def by force
    } moreover {
      fix G
      assume G: "G  set (trpairs F' D)"
         and c: "X⟨∨≠: (F@G)st  set constr"
         and e: "Q2 (trmspairs F  pair ` set F') X"

      have d_Q2: "Q2 (pair ` set D) X" unfolding Q2_def
      proof (intro allI impI)
        fix f T assume "Fun f T  subtermsset (pair ` set D)"
        then obtain d where d: "d  set D" "Fun f T  subterms (pair d)" by auto
        hence "fv (pair d)  set X = {}" using prems(4) unfolding pair_def by force
        thus "T = []  (s  set T. s  Var ` set X)"
          by (metis fv_disj_Fun_subterm_param_cases d(2))
      qed

      have "trmspairs (F@G)  trmspairs F  pair ` set F'  pair ` set D"
        using trpairs_trms_subset[OF G] by auto
      hence "Q2 (trmspairs (F@G)) X" using Q2_subset[OF _ Q2_supset[OF e d_Q2]] by metis
      hence "tfrstp (X⟨∨≠: (F@G)st)" by (metis Q2_def tfrstp.simps(2))
    } ultimately have 4: "list_all tfrstp constr" when "Q2 (trmspairs F  pair ` set F') X"
      using that Ball_set by blast

    have 5: "list_all tfrstp constr" using 2 3 4 by metis

    show ?case using 1 5 A''(1) by simp
  qed
qed

lemma tr_tfr:
  assumes "A'  set (tr A [])" and "tfrsst A" and "fvsst A  bvarssst A = {}"
  shows "tfrst A'"
proof -
  have *: "trmsst A'  trmssst A  pair ` setopssst A" using tr_trms_subset[OF assms(1)] by simp
  hence "SMP (trmsst A')  SMP (trmssst A  pair ` setopssst A)" using SMP_mono by simp
  moreover have "tfrset (trmssst A  pair ` setopssst A)" using assms(2) unfolding tfrsst_def by fast
  ultimately have 1: "tfrset (trmsst A')" by (metis tfr_subset(2)[OF _ *])

  have **: "list_all tfrsstp A" using assms(2) unfolding tfrsst_def by fast
  have "pair ` setopssst A  SMP (trmssst A  pair ` setopssst A) - Var`𝒱"
    using setopssst_are_pairs unfolding pair_def by auto
  hence ***: "t  pair`setopssst A. t'  pair`setopssst A. (δ. Unifier δ t t')  Γ t = Γ t'"
    using assms(2) unfolding tfrsst_def tfrset_def by blast
  have 2: "list_all tfrstp A'"
    using tr_tfrsstp[OF assms(1) ** assms(3)] *** unfolding pair_def by fastforce

  show ?thesis by (metis 1 2 tfrst_def)
qed

private lemma fun_pair_ineqs:
  assumes "d p δ p θ  d' p "
  shows "pair d  δ  θ  pair d'  "
proof -
  have "d p (δ s θ)  d' p " using assms subst_pair_compose by metis
  hence "pair d  (δ s θ)  pair d'  " using fun_pair_eq_subst by metis
  thus ?thesis by simp
qed

private lemma tr_Delete_constr_iff_aux1:
  assumes "d  set Di. (t,s) p  = d p "
  and "d  set D - set Di. (t,s) p   d p "
  shows "M; (map (λd. check: (pair (t,s))  (pair d)st) Di)@
             (map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di])d "
proof -
  from assms(2) have
    "M; map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di]d "
  proof (induction D)
    case (Cons d D)
    hence IH: "M; map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD . d  set Di]d " by auto
    thus ?case
    proof (cases "d  set Di")
      case False
      hence "(t,s) p   d p " using Cons by simp
      hence "pair (t,s)    pair d  " using fun_pair_eq_subst by metis
      moreover have "t (δ::('fun,'var) subst). subst_domain δ = {}  t  δ = t" by auto
      ultimately have "δ. subst_domain δ = {}  pair (t,s)  δ    pair d  δ  " by metis
      thus ?thesis using IH by (simp add: ineq_model_def)
    qed simp
  qed simp
  moreover {
    fix B assume "M; Bd " 
    with assms(1) have "M; (map (λd. check: (pair (t,s))  (pair d)st) Di)@Bd "
      unfolding pair_def by (induction Di) auto
  } ultimately show ?thesis by metis
qed

private lemma tr_Delete_constr_iff_aux2:
  assumes "ground M"
  and "M; (map (λd. check: (pair (t,s))  (pair d)st) Di)@
           (map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di])d "
  shows "(d  set Di. (t,s) p  = d p )  (d  set D - set Di. (t,s) p   d p )"
proof -
  let ?c1 = "map (λd. check: (pair (t,s))  (pair d)st) Di"
  let ?c2 = "map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di]"

  have "M set  = M" using assms(1) subst_all_ground_ident by metis
  moreover have "ikst ?c1 = {}" by auto
  ultimately have *:
       "M; map (λd. check: (pair (t,s))  (pair d)st) Did "
       "M; map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di]d "
    using strand_sem_split(3,4)[of M ?c1 ?c2 ] assms(2) by auto
  
  from *(1) have 1: "d  set Di. (t,s) p  = d p " unfolding pair_def by (induct Di) auto
  from *(2) have 2: "d  set D - set Di. (t,s) p   d p "
  proof (induction D arbitrary: Di)
    case (Cons d D) thus ?case
    proof (cases "d  set Di")
      case False
      hence IH: "d  set D - set Di. (t,s) p   d p " using Cons by force
      have "t (δ::('fun,'var) subst). subst_domain δ = {}  ground (subst_range δ)  δ = Var"
        by auto
      moreover have "ineq_model  [] [((pair (t,s)), (pair d))]"
        using False Cons.prems by simp
      ultimately have "pair (t,s)    pair d  " by (simp add: ineq_model_def)
      thus ?thesis using IH unfolding pair_def by force
    qed simp
  qed simp

  show ?thesis by (metis 1 2)
qed

private lemma tr_Delete_constr_iff:
  fixes ::"('fun,'var) subst"
  assumes "ground M"
  shows "set Di pset   {(t,s) p }  (t,s) p   (set D - set Di) pset  
         M; (map (λd. check: (pair (t,s))  (pair d)st) Di)@
             (map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di])d "
proof -
  let ?constr = "(map (λd. check: (pair (t,s))  (pair d)st) Di)@
                 (map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di])"
  { assume "set Di pset   {(t,s) p }" "(t,s) p   (set D - set Di) pset "
    hence "d  set Di. (t,s) p  = d p " "d  set D - set Di. (t,s) p   d p "
      by auto
    hence "M; ?constrd " using tr_Delete_constr_iff_aux1 by simp
  } moreover {
    assume "M; ?constrd "
    hence "d  set Di. (t,s) p  = d p " "d  set D - set Di. (t,s) p   d p "
      using assms tr_Delete_constr_iff_aux2 by auto
    hence "set Di pset   {(t,s) p }  (t,s) p   (set D - set Di) pset " by force
  } ultimately show ?thesis by metis
qed

private lemma tr_NotInSet_constr_iff:
  fixes ::"('fun,'var) subst"
  assumes "(t,t')  set D. (fv t  fv t')  set X = {}"
  shows "(δ. subst_domain δ = set X  ground (subst_range δ)  (t,s) p δ p   set D pset )
           M; map (λd. X⟨∨≠: [(pair (t,s), pair d)]st) Dd "
proof -
  { assume "δ. subst_domain δ = set X  ground (subst_range δ)  (t,s) p δ p   set D pset "
    with assms have "M; map (λd. X⟨∨≠: [(pair (t,s), pair d)]st) Dd "
    proof (induction D)
      case (Cons d D)
      obtain t' s' where d: "d = (t',s')" by moura
      have "M; map (λd. X⟨∨≠: [(pair (t,s), pair d)]st) Dd "
           "map (λd. X⟨∨≠: [(pair (t,s), pair d)]st) (d#D) =
            X⟨∨≠: [(pair (t,s), pair d)]st#map (λd. X⟨∨≠: [(pair (t,s), pair d)]st) D"
        using Cons by auto
      moreover have
          "δ. subst_domain δ = set X  ground (subst_range δ)  pair (t, s)  δ    pair d  "
        using fun_pair_ineqs[of  _  "(t,s)"  d] Cons.prems(2) by auto
      moreover have "(fv t'  fv s')  set X = {}" using Cons.prems(1) d by auto
      hence "δ. subst_domain δ = set X  pair d  δ = pair d" using d unfolding pair_def by auto
      ultimately show ?case by (simp add: ineq_model_def)
    qed simp
  } moreover {
    fix δ::"('fun,'var) subst"
    assume "M; map (λd. X⟨∨≠: [(pair (t,s), pair d)]st) Dd "
      and δ: "subst_domain δ = set X" "ground (subst_range δ)"
    with assms have "(t,s) p δ p   set D pset "
    proof (induction D)
      case (Cons d D)
      obtain t' s' where d: "d = (t',s')" by moura
      have "(t,s) p δ p   set D pset "
           "pair (t,s)  δ    pair d  δ  "
        using Cons d by (auto simp add: ineq_model_def simp del: subst_range.simps)
      moreover have "pair d  δ = pair d"
        using Cons.prems(1) fun_pair_subst[of d δ] d δ(1) unfolding pair_def by auto
      ultimately show ?case unfolding pair_def by force
    qed simp
  } ultimately show ?thesis by metis
qed

lemma tr_NegChecks_constr_iff:
  "(Gset L. ineq_model  X (F@G))  M; map (λG. X⟨∨≠: (F@G)st) Ld " (is ?A)
  "negchecks_model  D X F F'  M; D; [X⟨∨≠: F ∨∉: F']s " (is ?B)
proof -
  show ?A by (induct L) auto
  show ?B by simp
qed

lemma trpairs_sem_equiv:
  fixes ::"('fun,'var) subst"
  assumes "(t,t')  set D. (fv t  fv t')  set X = {}"
  shows "negchecks_model  (set D pset ) X F F' 
         (G  set (trpairs F' D). ineq_model  X (F@G))"
proof -
  define P where
    "P  λδ::('fun,'var) subst. subst_domain δ = set X  ground (subst_range δ)" 

  define Ineq where
    "Ineq  λ(δ::('fun,'var) subst) F. list_ex (λf. fst f  δ s   snd f  δ s ) F"

  define Ineq' where
    "Ineq'  λ(δ::('fun,'var) subst) F. list_ex (λf. fst f  δ s   snd f  ) F"
  
  define Notin where
    "Notin  λ(δ::('fun,'var) subst) D F'. list_ex (λf. f p δ s   set D pset ) F'"

  have sublmm:
      "((s,t) p δ s   set D pset )  (list_all (λd. Ineq' δ [(pair (s,t),pair d)]) D)"
    for s t δ D
    unfolding pair_def by (induct D) (auto simp add: Ineq'_def)

  have "Notin δ D F'  (G  set (trpairs F' D). Ineq' δ G)"
    (is "?A  ?B")
    when "P δ" for δ
  proof
    show "?A  ?B"
    proof (induction F' D rule: trpairs.induct)
      case (2 s t F' D)
      show ?case
      proof (cases "Notin δ D F'")
        case False
        hence "(s,t) p δ s   set D pset "
          using "2.prems"
          by (auto simp add: Notin_def)
        hence "pair (s,t)  δ s   pair d  " when "d  set D" for d
          using that sublmm Ball_set[of D "λd. Ineq' δ [(pair (s,t), pair d)]"]
          by (simp add: Ineq'_def)
        moreover have "d  set D. G'. G = (pair (s,t), pair d)#G'"
          when "G  set (trpairs ((s,t)#F') D)" for G
          using that trpairs_index[OF that, of 0] by force
        ultimately show ?thesis by (simp add: Ineq'_def)
      qed (auto dest: "2.IH" simp add: Ineq'_def)
    qed (simp add: Notin_def)

    have "¬?A  ¬?B"
    proof (induction F' D rule: trpairs.induct)
      case (2 s t F' D)
      then obtain G where G: "G  set (trpairs F' D)" "¬Ineq' δ G"
        by (auto simp add: Notin_def)

      obtain d where d: "d  set D" "pair (s,t)  δ s  = pair d  "
        using "2.prems"
        unfolding pair_def by (auto simp add: Notin_def)
      thus ?case
        using G(2) trpairs_cons[OF G(1) d(1)]
        by (auto simp add: Ineq'_def)
    qed (simp add: Ineq'_def)
    thus "?B  ?A" by metis
  qed
  hence *: "(δ. P δ  Ineq δ F  Notin δ D F') 
            (G  set (trpairs F' D). δ. P δ  Ineq δ F  Ineq' δ G)"
    by auto

  have "snd g  δ = snd g"
    when "G  set (trpairs F' D)" "g  set G" "P δ"
    for δ g G
    using assms that(3) trpairs_has_pair_lists[OF that(1,2)]
    unfolding pair_def by (fastforce simp add: P_def)
  hence **: "Ineq' δ G = Ineq δ G"
    when "G  set (trpairs F' D)" "P δ"
    for δ G
    using Bex_set[of G "λf. fst f  δ s   snd f  "]
          Bex_set[of G "λf. fst f  δ s   snd f  δ s "]
          that
    by (simp add: Ineq_def Ineq'_def)
  
  show ?thesis
    using * **
    by (simp add: Ineq_def Ineq'_def Notin_def P_def negchecks_model_def ineq_model_def)
qed

lemma tr_sem_equiv':
  assumes "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
    and "fvsst A  bvarssst A = {}"
    and "ground M"
    and: "interpretationsubst "
  shows "M; set D pset ; As   (A'  set (tr A D). M; A'd )" (is "?P  ?Q")
proof
  have ℐ_grounds: "t. fv (t  ) = {}" by (rule interpretation_grounds[OF])
  have "A'  set (tr A D). M; A'd " when ?P using that assms(1,2,3)
  proof (induction A arbitrary: D rule: strand_sem_stateful_induct)
    case (ConsRcv M D t A)
    have "insert (t  ) M; set D pset ; As "
         "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
         "fvsst A  bvarssst A = {}" "ground (insert (t  ) M)"
      using ℐ ConsRcv.prems unfolding fvsst_def bvarssst_def by force+
    then obtain A' where A': "A'  set (tr A D)" "insert (t  ) M; A'd " by (metis ConsRcv.IH)
    thus ?case by auto
  next
    case (ConsSnd M D t A)
    have "M; set D pset ; As "
         "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
         "fvsst A  bvarssst A = {}" "ground M"
      and *: "M  t  "
      using ℐ ConsSnd.prems unfolding fvsst_def bvarssst_def by force+
    then obtain A' where A': "A'  set (tr A D)" "M; A'd " by (metis ConsSnd.IH)
    thus ?case using * by auto
  next
    case (ConsEq M D ac t t' A)
    have "M; set D pset ; As "
         "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
         "fvsst A  bvarssst A = {}" "ground M"
      and *: "t   = t'  "
      using ℐ ConsEq.prems unfolding fvsst_def bvarssst_def by force+
    then obtain A' where A': "A'  set (tr A D)" "M; A'd " by (metis ConsEq.IH)
    thus ?case using * by auto
  next
    case (ConsIns M D t s A)
    have "M; set (List.insert (t,s) D) pset ; As "
         "(t,t')  set (List.insert (t,s) D). (fv t  fv t')  bvarssst A = {}"
         "fvsst A  bvarssst A = {}" "ground M"
      using ConsIns.prems unfolding fvsst_def bvarssst_def by force+
    then obtain A' where A': "A'  set (tr A (List.insert (t,s) D))" "M; A'd "
      by (metis ConsIns.IH)
    thus ?case by auto
  next
    case (ConsDel M D t s A)
    have *: "M; (set D pset ) - {(t,s) p }; As "
            "(t,t')set D. (fv t  fv t')  bvarssst A = {}"
            "fvsst A  bvarssst A = {}" "ground M"
      using ConsDel.prems unfolding fvsst_def bvarssst_def by force+
    then obtain Di where Di:
        "Di  set D" "Di pset   {(t,s) p }" "(t,s) p   (set D - Di) pset "
      using subset_subst_pairs_diff_exists'[of "set D"] by moura
    hence **: "(set D pset ) - {(t,s) p } = (set D - Di) pset " by blast

    obtain Di' where Di': "set Di' = Di" "Di'  set (subseqs D)"
      using subset_sublist_exists[OF Di(1)] by moura
    hence ***: "(set D pset ) - {(t,s) p } = (set [dD. d  set Di'] pset )"
      using Di ** by auto
    
    define constr where "constr 
        map (λd. check: (pair (t,s))  (pair d)st) Di'@
        map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di']"
    
    have ****: "(t,t')set [dD. d  set Di']. (fv t  fv t')  bvarssst A = {}"
      using *(2) Di(1) Di'(1) subseqs_set_subset[OF Di'(2)] by simp
    have "set D - Di = set [dD. d  set Di']" using Di Di' by auto
    hence *****: "M; set [dD. d  set Di'] pset ; As "
      using *(1) ** by metis
    obtain A' where A': "A'  set (tr A [dD. d  set Di'])" "M; A'd "
      using ConsDel.IH[OF ***** **** *(3,4)] by moura
    hence constr_sat: "M; constrd "
      using Di Di' *(1) *** tr_Delete_constr_iff[OF *(4), of  Di' t s D] 
      unfolding constr_def by auto

    have "constr@A'  set (tr (Delete t s#A) D)" using A'(1) Di' unfolding constr_def by auto
    moreover have "ikst constr = {}" unfolding constr_def by auto
    hence "M set ; constrd " "M  (ikst constr set ); A'd "
      using constr_sat A'(2) subst_all_ground_ident[OF *(4)] by simp_all
    ultimately show ?case
      using strand_sem_append(2)[of _ _ ]
            subst_all_ground_ident[OF *(4), of ]
      by metis
  next
    case (ConsIn M D ac t s A)
    have "M; set D pset ; As "
         "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
         "fvsst A  bvarssst A = {}" "ground M"
      and *: "(t,s) p   set D pset "
      using ℐ ConsIn.prems unfolding fvsst_def bvarssst_def by force+
    then obtain A' where A': "A'  set (tr A D)" "M; A'd " by (metis ConsIn.IH)
    moreover obtain d where "d  set D" "pair (t,s)   = pair d  "
      using * unfolding pair_def by auto
    ultimately show ?case using * by auto
  next
    case (ConsNegChecks M D X F F' A)
    let ?ineqs = "(map (λG. X⟨∨≠: (F@G)st) (trpairs F' D))"
    have 1: "M; set D pset ; As " "ground M" using ConsNegChecks by auto
    have 2: "(t,t')  set D. (fv t  fv t')  bvarssst A = {}" "fvsst A  bvarssst A = {}" 
      using ConsNegChecks.prems(2,3)unfolding fvsst_def bvarssst_def by fastforce+
    
    have 3: "negchecks_model  (set D pset ) X F F'" using ConsNegChecks.prems(1) by simp
    from 1 2 obtain A' where A': "A'  set (tr A D)" "M; A'd " by (metis ConsNegChecks.IH)
    
    have 4: "(t,t')  set D. (fv t  fv t')  set X = {}"
      using ConsNegChecks.prems(2) unfolding bvarssst_def by auto
    
    have "M; ?ineqsd "
      using 3 trpairs_sem_equiv[OF 4] tr_NegChecks_constr_iff
      by metis
    moreover have "ikst ?ineqs = {}" by auto
    moreover have "M set  = M" using 1(2)by (simp add: subst_all_ground_ident)
    ultimately show ?case
      using strand_sem_append(2)[of M ?ineqs  A'] A'
      by force
  qed simp
  thus "?P  ?Q" by metis

  have "(A'  set (tr A D). M; A'd )  ?P" using assms(1,2,3)
  proof (induction A arbitrary: D rule: strand_sem_stateful_induct)
    case (ConsRcv M D t A)
    have "A'  set (tr A D). insert (t  ) M; A'd "
         "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
         "fvsst A  bvarssst A = {}" "ground (insert (t  ) M)"
      using ℐ ConsRcv.prems unfolding fvsst_def bvarssst_def by force+
    hence "insert (t  ) M; set D pset ; As " by (metis ConsRcv.IH)
    thus ?case by auto
  next
    case (ConsSnd M D t A)
    have "A'  set (tr A D). M; A'd "
         "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
         "fvsst A  bvarssst A = {}" "ground M"
      and *: "M  t  "
      using ℐ ConsSnd.prems unfolding fvsst_def bvarssst_def by force+
    hence "M; set D pset ; As " by (metis ConsSnd.IH)
    thus ?case using * by auto
  next
    case (ConsEq M D ac t t' A)
    have "A'  set (tr A D). M; A'd "
         "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
         "fvsst A  bvarssst A = {}" "ground M"
      and *: "t   = t'  "
      using ℐ ConsEq.prems unfolding fvsst_def bvarssst_def by force+
    hence "M; set D pset ; As " by (metis ConsEq.IH)
    thus ?case using * by auto
  next
    case (ConsIns M D t s A)
    hence "A'  set (tr A (List.insert (t,s) D)). M; A'd "
          "(t,t')  set (List.insert (t,s) D). (fv t  fv t')  bvarssst A = {}"
          "fvsst A  bvarssst A = {}" "ground M"
      unfolding fvsst_def bvarssst_def by auto+
    hence "M; set (List.insert (t,s) D) pset ; As " by (metis ConsIns.IH)
    thus ?case by auto
  next
    case (ConsDel M D t s A)
    define constr where "constr 
      λDi. map (λd. check: (pair (t,s))  (pair d)st) Di@
           map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dD. d  set Di]"
    let ?flt = "λDi. filter (λd. d  set Di) D"

    have "Di  set (subseqs D). B'  set (tr A (?flt Di)). B = constr Di@B'"
      when "B  set (tr (delete⟨t,s#A) D)" for B
      using that unfolding constr_def by auto
    then obtain A' Di where A':
        "constr Di@A'  set (tr (Delete t s#A) D)"
        "A'  set (tr A (?flt Di))"
        "Di  set (subseqs D)"
        "M; constr Di@A'd "
      using ConsDel.prems(1) by blast

    have 1: "(t,t')set (?flt Di). (fv t  fv t')  bvarssst A = {}" using ConsDel.prems(2) by auto
    have 2: "fvsst A  bvarssst A = {}" using ConsDel.prems(3) by force+
    have "ikst (constr Di) = {}" unfolding constr_def by auto
    hence 3: "M; A'd "
      using subst_all_ground_ident[OF ConsDel.prems(4)] A'(4)
            strand_sem_split(4)[of M "constr Di" A' ]
      by simp
    have IH: "M; set (?flt Di) pset ; As "
      by (metis ConsDel.IH[OF _ 1 2 ConsDel.prems(4)] 3 A'(2))

    have "M; constr Did "
      using subst_all_ground_ident[OF ConsDel.prems(4)] strand_sem_split(3) A'(4)
      by metis
    hence *: "set Di pset   {(t,s) p }" "(t,s) p   (set D - set Di) pset "
      using tr_Delete_constr_iff[OF ConsDel.prems(4), of  Di t s D] unfolding constr_def by auto
    have 4: "set (?flt Di) pset  = (set D pset ) - {((t,s) p )}"
    proof
      show "set (?flt Di) pset   (set D pset ) - {((t,s) p )}"
      proof
        fix u u' assume u: "(u,u')  set (?flt Di) pset "
        then obtain v v' where v: "(v,v')  set D - set Di" "(v,v') p  = (u,u')" by auto
        hence "(u,u')  (t,s) p " using * by force
        thus "(u,u')   (set D pset ) - {((t,s) p )}"
          using u v * subseqs_set_subset[OF A'(3)] by auto
      qed
      show "(set D pset ) - {((t,s) p )}  set (?flt Di) pset "
        using * subseqs_set_subset[OF A'(3)] by force
    qed

    show ?case using 4 IH by simp
  next
    case (ConsIn M D ac t s A)
    have "A'  set (tr A D). M; A'd "
         "(t,t')  set D. (fv t  fv t')  bvarssst A = {}"
         "fvsst A  bvarssst A = {}" "ground M"
      and *: "(t,s) p   set D pset "
      using ConsIn.prems(1,2,3,4) apply (fastforce, fastforce, fastforce, fastforce)
      using ConsIn.prems(1) tr.simps(7)[of ac t s A D] unfolding pair_def by fastforce
    hence "M; set D pset ; As " by (metis ConsIn.IH)
    moreover obtain d where "d  set D" "pair (t,s)   = pair d  "
      using * unfolding pair_def by auto
    ultimately show ?case using * by auto
  next
    case (ConsNegChecks M D X F F' A)
    let ?ineqs = "(map (λG. X⟨∨≠: (F@G)st) (trpairs F' D))"

    obtain B where B:
        "?ineqs@B  set (tr (NegChecks X F F'#A) D)" "M; ?ineqs@Bd " "B  set (tr A D)"
      using ConsNegChecks.prems(1) by moura
    moreover have "M set  = M"
      using ConsNegChecks.prems(4)by (simp add: subst_all_ground_ident)
    moreover have "ikst ?ineqs = {}" by auto
    ultimately have "M; Bd " using strand_sem_split(4)[of M ?ineqs B ] by simp
    moreover have "(t,t')set D. (fv t  fv t')  bvarssst A = {}" "fvsst A  bvarssst A = {}"
      using ConsNegChecks.prems(2,3) unfolding fvsst_def bvarssst_def by force+
    ultimately have "M; set D pset ; As "
      by (metis ConsNegChecks.IH B(3) ConsNegChecks.prems(4))
    moreover have "(t, t')set D. (fv t  fv t')  set X = {}"
      using ConsNegChecks.prems(2) unfolding bvarssst_def by force
    ultimately show ?case
      using trpairs_sem_equiv tr_NegChecks_constr_iff
            B(2) strand_sem_split(3)[of M ?ineqs B ] M set  = M
      by simp
  qed simp
  thus "?Q  ?P" by metis
qed

lemma tr_sem_equiv:
  assumes "fvsst A  bvarssst A = {}" and "interpretationsubst "
  shows " s A  (A'  set (tr A []). (  A'))"
using tr_sem_equiv'[OF _ assms(1) _ assms(2), of "[]" "{}"]
unfolding constr_sem_d_def
by auto

theorem stateful_typing_result:
  assumes "wfsst 𝒜"
    and "tfrsst 𝒜"
    and "wftrms (trmssst 𝒜)"
    and "interpretationsubst "
    and " s 𝒜"
  obtains τ
    where "interpretationsubst τ"
    and "τ s 𝒜"
    and "wtsubst τ"
    and "wftrms (subst_range τ)"
proof -
  obtain 𝒜' where 𝒜':
      "𝒜'  set (tr 𝒜 [])" "  𝒜'"
    using tr_sem_equiv[of 𝒜] assms(1,4,5)
    by auto

  have *: "wfst {} 𝒜'"
          "fvst 𝒜'  bvarsst 𝒜' = {}"
          "tfrst 𝒜'" "wftrms (trmsst 𝒜')"
    using tr_wf[OF 𝒜'(1) assms(1,3)]
          tr_tfr[OF 𝒜'(1) assms(2)] assms(1)
    by metis+

  obtain τ whereτ:
      "interpretationsubst τ" "{}; 𝒜'd τ"
      "wtsubst τ" "wftrms (subst_range τ)"
    using wt_attack_if_tfr_attack_d 
          * Ana_invar_subst' assms(4)
          𝒜'(2)
    unfolding constr_sem_d_def
    by moura

  thus ?thesis
    using that tr_sem_equiv[of 𝒜] assms(1,3) 𝒜'(1)
    unfolding constr_sem_d_def
    by auto
qed

end

end

subsection ‹Proving type-flaw resistance automatically›
definition pair' where
  "pair' pair_fun d  case d of (t,t')  Fun pair_fun [t,t']"

fun comp_tfrsstp where
  "comp_tfrsstp Γ pair_fun (_: t  t') = (mgu t t'  None  Γ t = Γ t')"
| "comp_tfrsstp Γ pair_fun (X⟨∨≠: F ∨∉: F') = (
    (F' = []  (x  fvpairs F - set X. is_Var (Γ (Var x)))) 
    (u  subtermsset (trmspairs F  pair' pair_fun ` set F').
      is_Fun u  (args u = []  (s  set (args u). s  Var ` set X))))"
| "comp_tfrsstp _ _ _ = True"

definition comp_tfrsst where
  "comp_tfrsst arity Ana Γ pair_fun M S 
    list_all (comp_tfrsstp Γ pair_fun) S 
    list_all (wftrm' arity) (trms_listsst S) 
    has_all_wt_instances_of Γ (trmssst S  pair' pair_fun ` setopssst S) (set M) 
    comp_tfrset arity Ana Γ M"

locale stateful_typed_model' = stateful_typed_model arity public Ana Γ Pair
  for arity::"'fun  nat"
    and public::"'fun  bool"
    and Ana::"('fun,(('fun,'atom::finite) term_type × nat)) term
               (('fun,(('fun,'atom) term_type × nat)) term list
                 × ('fun,(('fun,'atom) term_type × nat)) term list)"
    and Γ::"('fun,(('fun,'atom) term_type × nat)) term  ('fun,'atom) term_type"
    and Pair::"'fun"
  +
  assumes Γ_Var_fst': "τ n m. Γ (Var (τ,n)) = Γ (Var (τ,m))"
    and Ana_const': "c T. arity c = 0  Ana (Fun c T) = ([], [])"
begin

sublocale typed_model'
by (unfold_locales, rule Γ_Var_fst', metis Ana_const', metis Ana_subst')

lemma pair_code:
  "pair d = pair' Pair d"
by (simp add: pair_def pair'_def)

lemma tfrsstp_is_comp_tfrsstp: "tfrsstp a = comp_tfrsstp Γ Pair a"
proof (cases a)
  case (Equality ac t t')
  thus ?thesis
    using mgu_always_unifies[of t _ t'] mgu_gives_MGU[of t t']
    by auto
next
  case (NegChecks X F F')
  thus ?thesis
    using tfrsstp.simps(2)[of X F F']
          comp_tfrsstp.simps(2)[of Γ Pair X F F']
          Fun_range_case(2)[of "subtermsset (trmspairs F  pair ` set F')"]
    unfolding is_Var_def pair_code[symmetric]
    by auto
qed auto

lemma tfrsst_if_comp_tfrsst:
  assumes "comp_tfrsst arity Ana Γ Pair M S"
  shows "tfrsst S"
unfolding tfrsst_def
proof
  have comp_tfrset_M: "comp_tfrset arity Ana Γ M"
    using assms unfolding comp_tfrsst_def by blast
  
  have wftrms_M: "wftrms (set M)"
      and wftrms_S: "wftrms (trmssst S  pair ` setopssst S)"
      and S_trms_instance_M: "has_all_wt_instances_of Γ (trmssst S  pair ` setopssst S) (set M)"
    using assms setopssst_wftrms(2)[of S] trms_listsst_is_trmssst[of S]
    unfolding comp_tfrsst_def comp_tfrset_def list_all_iff pair_code[symmetric] wftrm_code[symmetric]
              finite_SMP_representation_def
    by (meson, meson, blast, meson)

  show "tfrset (trmssst S  pair ` setopssst S)"
    using tfr_subset(3)[OF tfrset_if_comp_tfrset[OF comp_tfrset_M] SMP_SMP_subset]
          SMP_I'[OF wftrms_S wftrms_M S_trms_instance_M]
    by blast

  have "list_all (comp_tfrsstp Γ Pair) S" by (metis assms comp_tfrsst_def)
  thus "list_all tfrsstp S" by (induct S) (simp_all add: tfrsstp_is_comp_tfrsstp)
qed

lemma tfrsst_if_comp_tfrsst':
  assumes "comp_tfrsst arity Ana Γ Pair (SMP0  Ana Γ (trms_listsst S@map pair (setops_listsst S))) S"
  shows "tfrsst S"
by (rule tfrsst_if_comp_tfrsst[OF assms])

end

end

Theory Labeled_Strands

(*
(C) Copyright Andreas Viktor Hess, DTU, 2018-2020
(C) Copyright Sebastian A. Mödersheim, DTU, 2018-2020
(C) Copyright Achim D. Brucker, University of Sheffield, 2018-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Labeled_Strands.thy
    Author:     Andreas Viktor Hess, DTU
    Author:     Sebastian A. Mödersheim, DTU
    Author:     Achim D. Brucker, The University of Sheffield
*)

section ‹Labeled Strands›
theory Labeled_Strands
imports Strands_and_Constraints
begin

subsection ‹Definitions: Labeled Strands and Constraints›
datatype 'l strand_label =
  LabelN (the_LabelN: "'l") ("ln _")
| LabelS ("")

text ‹Labeled strands are strands whose steps are equipped with labels›
type_synonym ('a,'b,'c) labeled_strand_step = "'c strand_label × ('a,'b) strand_step"
type_synonym ('a,'b,'c) labeled_strand = "('a,'b,'c) labeled_strand_step list"

abbreviation is_LabelN where "is_LabelN n x  fst x = ln n"
abbreviation is_LabelS where "is_LabelS x  fst x = "

definition unlabel where "unlabel S  map snd S"
definition proj where "proj n S  filter (λs. is_LabelN n s  is_LabelS s) S"
abbreviation proj_unl where "proj_unl n S  unlabel (proj n S)"

abbreviation wfrestrictedvarslst where "wfrestrictedvarslst S  wfrestrictedvarsst (unlabel S)"

abbreviation subst_apply_labeled_strand_step (infix "lstp" 51) where
  "x lstp θ  (case x of (l, s)  (l, s stp θ))"

abbreviation subst_apply_labeled_strand (infix "lst" 51) where
  "S lst θ  map (λx. x lstp θ) S"

abbreviation trmslst where "trmslst S  trmsst (unlabel S)"
abbreviation trms_projlst where "trms_projlst n S  trmsst (proj_unl n S)"

abbreviation varslst where "varslst S  varsst (unlabel S)"
abbreviation vars_projlst where "vars_projlst n S  varsst (proj_unl n S)"

abbreviation bvarslst where "bvarslst S  bvarsst (unlabel S)"
abbreviation fvlst where "fvlst S  fvst (unlabel S)"

abbreviation wflst where "wflst V S  wfst V (unlabel S)"


subsection ‹Lemmata: Projections›
lemma is_LabelS_proj_iff_not_is_LabelN:
  "list_all is_LabelS (proj l A)  ¬list_ex (is_LabelN l) A"
by (induct A) (auto simp add: proj_def)

lemma proj_subset_if_no_label:
  assumes "¬list_ex (is_LabelN l) A"
  shows "set (proj l A)  set (proj l' A)"
    and "set (proj_unl l A)  set (proj_unl l' A)"
using assms by (induct A) (auto simp add: unlabel_def proj_def)

lemma proj_in_setD:
  assumes a: "a  set (proj l A)"
  obtains k b where "a = (k, b)" "k = (ln l)  k = "
using that a unfolding proj_def by (cases a) auto

lemma proj_set_mono:
  assumes "set A  set B"
  shows "set (proj n A)  set (proj n B)"
    and "set (proj_unl n A)  set (proj_unl n B)"
using assms unfolding proj_def unlabel_def by auto

lemma unlabel_nil[simp]: "unlabel [] = []"
by (simp add: unlabel_def)

lemma unlabel_mono: "set A  set B  set (unlabel A)  set (unlabel B)"
by (auto simp add: unlabel_def)

lemma unlabel_in: "(l,x)  set A  x  set (unlabel A)"
unfolding unlabel_def by force

lemma unlabel_mem_has_label: "x  set (unlabel A)  l. (l,x)  set A"
unfolding unlabel_def by auto

lemma proj_nil[simp]: "proj n [] = []" "proj_unl n [] = []"
unfolding unlabel_def proj_def by auto

lemma singleton_lst_proj[simp]:
  "proj_unl l [(ln l, a)] = [a]"
  "l  l'  proj_unl l' [(ln l, a)] = []"
  "proj_unl l [(, a)] = [a]"
  "unlabel [(l'', a)] = [a]"
unfolding proj_def unlabel_def by simp_all

lemma unlabel_nil_only_if_nil[simp]: "unlabel A = []  A = []"
unfolding unlabel_def by auto

lemma unlabel_Cons[simp]:
  "unlabel ((l,a)#A) = a#unlabel A"
  "unlabel (b#A) = snd b#unlabel A"
unfolding unlabel_def by simp_all

lemma unlabel_append[simp]: "unlabel (A@B) = unlabel A@unlabel B"
unfolding unlabel_def by auto

lemma proj_Cons[simp]:
  "proj n ((ln n,a)#A) = (ln n,a)#proj n A"
  "proj n ((,a)#A) = (,a)#proj n A"
  "m  n  proj n ((ln m,a)#A) = proj n A"
  "l = (ln n)  proj n ((l,a)#A) = (l,a)#proj n A"
  "l =   proj n ((l,a)#A) = (l,a)#proj n A"
  "fst b    fst b  (ln n)  proj n (b#A) = proj n A"
unfolding proj_def by auto

lemma proj_append[simp]:
  "proj l (A'@B') = proj l A'@proj l B'"
  "proj_unl l (A@B) = proj_unl l A@proj_unl l B"
unfolding proj_def unlabel_def by auto

lemma proj_unl_cons[simp]:
  "proj_unl l ((ln l, a)#A) = a#proj_unl l A"
  "l  l'  proj_unl l' ((ln l, a)#A) = proj_unl l' A"
  "proj_unl l ((, a)#A) = a#proj_unl l A"
unfolding proj_def unlabel_def by simp_all

lemma trms_unlabel_proj[simp]:
  "trmsstp (snd (ln l, x))  trms_projlst l [(ln l, x)]"
by auto

lemma trms_unlabel_star[simp]:
  "trmsstp (snd (, x))  trms_projlst l [(, x)]"
by auto

lemma trmslst_union[simp]: "trmslst A = (l. trms_projlst l A)"
proof (induction A)
  case (Cons a A)
  obtain l s where ls: "a = (l,s)" by moura
  have "trmslst [a] = (l. trms_projlst l [a])"
  proof -
    have *: "trmslst [a] = trmsstp s" using ls by simp
    show ?thesis
    proof (cases l)
      case (LabelN n)
      hence "trms_projlst n [a] = trmsstp s" using ls by simp
      moreover have "m. n  m  trms_projlst m [a] = {}" using ls LabelN by auto
      ultimately show ?thesis using * ls by fastforce
    next
      case LabelS
      hence "l. trms_projlst l [a] = trmsstp s" using ls by auto
      thus ?thesis using * ls by fastforce
    qed
  qed
  moreover have "l. trms_projlst l (a#A) = trms_projlst l [a]  trms_projlst l A"
    unfolding unlabel_def proj_def by auto
  hence "(l. trms_projlst l (a#A)) = (l. trms_projlst l [a])  (l. trms_projlst l A)" by auto
  ultimately show ?case using Cons.IH ls by auto
qed simp

lemma trmslst_append[simp]: "trmslst (A@B) = trmslst A  trmslst B"
by (metis trmsst_append unlabel_append)

lemma trms_projlst_append[simp]: "trms_projlst l (A@B) = trms_projlst l A  trms_projlst l B"
by (metis (no_types, lifting) filter_append proj_def trmslst_append)

lemma trms_projlst_subset[simp]:
  "trms_projlst l A  trms_projlst l (A@B)"
  "trms_projlst l B  trms_projlst l (A@B)"
using trms_projlst_append[of l] by blast+

lemma trmslst_subset[simp]:
  "trmslst A  trmslst (A@B)"
  "trmslst B  trmslst (A@B)"
proof (induction A)
  case (Cons a A)
  obtain l s where *: "a = (l,s)" by moura
  { case 1 thus ?case using Cons * by auto }
  { case 2 thus ?case using Cons * by auto }
qed simp_all

lemma varslst_union: "varslst A = (l. vars_projlst l A)"
proof (induction A)
  case (Cons a A)
  obtain l s where ls: "a = (l,s)" by moura
  have "varslst [a] = (l. vars_projlst l [a])"
  proof -
    have *: "varslst [a] = varsstp s" using ls by auto
    show ?thesis
    proof (cases l)
      case (LabelN n)
      hence "vars_projlst n [a] = varsstp s" using ls by simp
      moreover have "m. n  m  vars_projlst m [a] = {}" using ls LabelN by auto
      ultimately show ?thesis using * ls by fast
    next
      case LabelS
      hence "l. vars_projlst l [a] = varsstp s" using ls by auto
      thus ?thesis using * ls by fast
    qed
  qed
  moreover have "l. vars_projlst l (a#A) = vars_projlst l [a]  vars_projlst l A"
    unfolding unlabel_def proj_def by auto
  hence "(l. vars_projlst l (a#A)) = (l. vars_projlst l [a])  (l. vars_projlst l A)"
    using strand_vars_split(1) by auto
  ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto
qed simp

lemma unlabel_Cons_inv:
  "unlabel A = b#B  A'. (n. A = (ln n, b)#A')  A = (, b)#A'"
proof -
  assume *: "unlabel A = b#B"
  then obtain l A' where "A = (l,b)#A'" unfolding unlabel_def by moura
  thus "A'. (l. A = (ln l, b)#A')  A = (, b)#A'" by (metis strand_label.exhaust)
qed

lemma unlabel_snoc_inv:
  "unlabel A = B@[b]  A'. (n. A = A'@[(ln n, b)])  A = A'@[(, b)]"
proof -
  assume *: "unlabel A = B@[b]"
  then obtain A' l where "A = A'@[(l,b)]"
    unfolding unlabel_def by (induct A rule: List.rev_induct) auto
  thus "A'. (n. A = A'@[(ln n, b)])  A = A'@[(, b)]" by (cases l) auto
qed

lemma proj_idem[simp]: "proj l (proj l A) = proj l A"
unfolding proj_def by auto

lemma proj_ikst_is_proj_rcv_set:
  "ikst (proj_unl n A) = {t. (ln n, Receive t)  set A  (, Receive t)  set A} "
using ikst_is_rcv_set unfolding unlabel_def proj_def by force

lemma unlabel_ikst_is_rcv_set:
  "ikst (unlabel A) = {t | l t. (l, Receive t)  set A}"
using ikst_is_rcv_set unfolding unlabel_def by force

lemma proj_ik_union_is_unlabel_ik:
  "ikst (unlabel A) = (l. ikst (proj_unl l A))"
proof
  show "(l. ikst (proj_unl l A))  ikst (unlabel A)"
    using unlabel_ikst_is_rcv_set[of A] proj_ikst_is_proj_rcv_set[of _ A] by auto

  show "ikst (unlabel A)  (l. ikst (proj_unl l A))"
  proof
    fix t assume "t  ikst (unlabel A)"
    then obtain l where "(l, Receive t)  set A"
      using ikst_is_rcv_set unlabel_mem_has_label[of _ A]
      by moura
    thus "t  (l. ikst (proj_unl l A))" using proj_ikst_is_proj_rcv_set[of _ A] by (cases l) auto
  qed
qed

lemma proj_ik_append[simp]:
  "ikst (proj_unl l (A@B)) = ikst (proj_unl l A)  ikst (proj_unl l B)"
using proj_append(2)[of l A B] ik_append by auto

lemma proj_ik_append_subst_all:
  "ikst (proj_unl l (A@B)) set I = (ikst (proj_unl l A) set I)  (ikst (proj_unl l B) set I)"
using proj_ik_append[of l] by auto

lemma ik_proj_subset[simp]: "ikst (proj_unl n A)  trms_projlst n A"
by auto

lemma prefix_proj:
  "prefix A B  prefix (unlabel A) (unlabel B)"
  "prefix A B  prefix (proj n A) (proj n B)"
  "prefix A B  prefix (proj_unl n A) (proj_unl n B)"
unfolding prefix_def unlabel_def proj_def by auto


subsection ‹Lemmata: Well-formedness›
lemma wfvarsoccsst_proj_union:
  "wfvarsoccsst (unlabel A) = (l. wfvarsoccsst (proj_unl l A))"
proof (induction A)
  case (Cons a A)
  obtain l s where ls: "a = (l,s)" by moura
  have "wfvarsoccsst (unlabel [a]) = (l. wfvarsoccsst (proj_unl l [a]))"
  proof -
    have *: "wfvarsoccsst (unlabel [a]) = wfvarsoccsstp s" using ls by auto
    show ?thesis
    proof (cases l)
      case (LabelN n)
      hence "wfvarsoccsst (proj_unl n [a]) = wfvarsoccsstp s" using ls by simp
      moreover have "m. n  m  wfvarsoccsst (proj_unl m [a]) = {}" using ls LabelN by auto
      ultimately show ?thesis using * ls by fast
    next
      case LabelS
      hence "l. wfvarsoccsst (proj_unl l [a]) = wfvarsoccsstp s" using ls by auto
      thus ?thesis using * ls by fast
    qed
  qed
  moreover have
      "wfvarsoccsst (proj_unl l (a#A)) =
       wfvarsoccsst (proj_unl l [a])  wfvarsoccsst (proj_unl l A)"
    for l
    unfolding unlabel_def proj_def by auto
  hence "(l. wfvarsoccsst (proj_unl l (a#A))) =
         (l. wfvarsoccsst (proj_unl l [a]))  (l. wfvarsoccsst (proj_unl l A))"
    using strand_vars_split(1) by auto
  ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto
qed simp

lemma wf_if_wf_proj:
  assumes "l. wfst V (proj_unl l A)"
  shows "wfst V (unlabel A)"
using assms
proof (induction A arbitrary: V rule: List.rev_induct)
  case (snoc a A)
  hence IH: "wfst V (unlabel A)" using proj_append(2)[of _ A] by auto
  obtain b l where b: "a = (ln l, b)  a = (, b)" by (cases a, metis strand_label.exhaust)
  hence *: "wfst V (proj_unl l A@[b])"
    by (metis snoc.prems proj_append(2) singleton_lst_proj(1) proj_unl_cons(1,3))
  thus ?case using IH b snoc.prems proj_append(2)[of l A "[a]"] unlabel_append[of A "[a]"]
  proof (cases b)
    case (Receive t)
    have "fv t  wfvarsoccsst (unlabel A)  V"
    proof
      fix x assume "x  fv t"
      hence "x  V  wfvarsoccsst (proj_unl l A)" using wf_append_exec[OF *] b Receive by auto
      thus "x  wfvarsoccsst (unlabel A)  V" using wfvarsoccsst_proj_union[of A] by auto
    qed
    hence "fv t  wfrestrictedvarsst (unlabel A)  V"
      using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] by blast
    hence "wfst V (unlabel A@[Receive t])" by (rule wf_rcv_append'''[OF IH])
    thus ?thesis using b Receive unlabel_append[of A "[a]"] by auto
  next
    case (Equality ac s t)
    have "fv t  wfvarsoccsst (unlabel A)  V" when "ac = Assign"
    proof
      fix x assume "x  fv t"
      hence "x  V  wfvarsoccsst (proj_unl l A)" using wf_append_exec[OF *] b Equality that by auto
      thus "x  wfvarsoccsst (unlabel A)  V" using wfvarsoccsst_proj_union[of A] by auto
    qed
    hence "fv t  wfrestrictedvarslst A  V" when "ac = Assign"
      using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] that by blast
    hence "wfst V (unlabel A@[Equality ac s t])"
      by (cases ac) (metis wf_eq_append'''[OF IH], metis wf_eq_check_append''[OF IH])
    thus ?thesis using b Equality unlabel_append[of A "[a]"] by auto
  qed auto
qed simp

end

Theory Parallel_Compositionality

(*
(C) Copyright Andreas Viktor Hess, DTU, 2018-2020
(C) Copyright Sebastian A. Mödersheim, DTU, 2018-2020
(C) Copyright Achim D. Brucker, University of Sheffield, 2018-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Parallel_Compositionality.thy
    Author:     Andreas Viktor Hess, DTU
    Author:     Sebastian A. Mödersheim, DTU
    Author:     Achim D. Brucker, The University of Sheffield
*)

section ‹Parallel Compositionality of Security Protocols›
text ‹\label{sec:Parallel-Compositionality}›
theory Parallel_Compositionality
imports Typing_Result Labeled_Strands
begin


subsection ‹Definitions: Labeled Typed Model Locale›
locale labeled_typed_model = typed_model arity public Ana Γ
  for arity::"'fun  nat"
    and public::"'fun  bool"
    and Ana::"('fun,'var) term  (('fun,'var) term list × ('fun,'var) term list)"
    and Γ::"('fun,'var) term  ('fun,'atom::finite) term_type"
  +
  fixes label_witness1 and label_witness2::"'lbl"
  assumes at_least_2_labels: "label_witness1  label_witness2"
begin

text ‹The Ground Sub-Message Patterns (GSMP)›
definition GSMP::"('fun,'var) terms  ('fun,'var) terms" where
  "GSMP P  {t  SMP P. fv t = {}}"

definition typing_cond where
  "typing_cond 𝒜 
    wfst {} 𝒜 
    fvst 𝒜  bvarsst 𝒜 = {} 
    tfrst 𝒜 
    wftrms (trmsst 𝒜) 
    Ana_invar_subst (ikst 𝒜  assignment_rhsst 𝒜)"


subsection ‹Definitions: GSMP Disjointedness and Parallel Composability›
definition GSMP_disjoint where
  "GSMP_disjoint P1 P2 Secrets  GSMP P1  GSMP P2  Secrets  {m. {} c m}"

definition declassifiedlst where
  "declassifiedlst (𝒜::('fun,'var,'lbl) labeled_strand)   {t. (, Receive t)  set 𝒜} set "

definition par_comp where
  "par_comp (𝒜::('fun,'var,'lbl) labeled_strand) (Secrets::('fun,'var) terms)  
    (l1 l2. l1  l2  GSMP_disjoint (trms_projlst l1 𝒜) (trms_projlst l2 𝒜) Secrets) 
    (s  Secrets. s'  subterms s. {} c s'  s'  Secrets) 
    ground Secrets"

definition strand_leakslst where
  "strand_leakslst 𝒜 Sec   (t  Sec - declassifiedlst 𝒜 . l. (  proj_unl l 𝒜@[Send t]))"

subsection ‹Definitions: Homogeneous and Numbered Intruder Deduction Variants›

definition proj_specific where
  "proj_specific n t 𝒜 Secrets  t  GSMP (trms_projlst n 𝒜) - (Secrets  {m. {} c m})"

definition heterogeneouslst where
  "heterogeneouslst t 𝒜 Secrets  (
    (l1 l2. s1  subterms t. s2  subterms t.
      l1  l2  proj_specific l1 s1 𝒜 Secrets  proj_specific l2 s2 𝒜 Secrets))"

abbreviation homogeneouslst where
  "homogeneouslst t 𝒜 Secrets  ¬heterogeneouslst t 𝒜 Secrets"

definition intruder_deduct_hom::
  "('fun,'var) terms  ('fun,'var,'lbl) labeled_strand  ('fun,'var) terms  ('fun,'var) term
   bool" ("_;_;_ hom _" 50)
where
  "M; 𝒜; Sec hom t  M; λt. homogeneouslst t 𝒜 Sec  t  GSMP (trmslst 𝒜) r t"

lemma intruder_deduct_hom_AxiomH[simp]:
  assumes "t  M"
  shows "M; 𝒜; Sec hom t"
using intruder_deduct_restricted.AxiomR[of t M] assms
unfolding intruder_deduct_hom_def
by blast

lemma intruder_deduct_hom_ComposeH[simp]:
  assumes "length X = arity f" "public f" "x. x  set X  M; 𝒜; Sec hom x"
  and "homogeneouslst (Fun f X) 𝒜 Sec" "Fun f X  GSMP (trmslst 𝒜)"
  shows "M; 𝒜; Sec hom Fun f X"
proof -
  let ?Q = "λt. homogeneouslst t 𝒜 Sec  t  GSMP (trmslst 𝒜)"
  show ?thesis
    using intruder_deduct_restricted.ComposeR[of X f M ?Q] assms
    unfolding intruder_deduct_hom_def
    by blast
qed

lemma intruder_deduct_hom_DecomposeH:
  assumes "M; 𝒜; Sec hom t" "Ana t = (K, T)" "k. k  set K  M; 𝒜; Sec hom k" "ti  set T"
  shows "M; 𝒜; Sec hom ti"
proof -
  let ?Q = "λt. homogeneouslst t 𝒜 Sec  t  GSMP (trmslst 𝒜)"
  show ?thesis
    using intruder_deduct_restricted.DecomposeR[of M ?Q t] assms
    unfolding intruder_deduct_hom_def
    by blast
qed

lemma intruder_deduct_hom_induct[consumes 1, case_names AxiomH ComposeH DecomposeH]:
  assumes "M; 𝒜; Sec hom t" "t. t  M  P M t"
          "X f. length X = arity f; public f;
                  x. x  set X  M; 𝒜; Sec hom x;
                  x. x  set X  P M x;
                  homogeneouslst (Fun f X) 𝒜 Sec;
                  Fun f X  GSMP (trmslst 𝒜)
                    P M (Fun f X)"
          "t K T ti. M; 𝒜; Sec hom t; P M t; Ana t = (K, T);
                       k. k  set K  M; 𝒜; Sec hom k;
                       k. k  set K  P M k; ti  set T  P M ti"
        shows "P M t"
proof -
  let ?Q = "λt. homogeneouslst t 𝒜 Sec  t  GSMP (trmslst 𝒜)"
  show ?thesis
    using intruder_deduct_restricted_induct[of M ?Q t "λM Q t. P M t"] assms
    unfolding intruder_deduct_hom_def
    by blast
qed

lemma ideduct_hom_mono:
  "M; 𝒜; Sec hom t; M  M'  M'; 𝒜; Sec hom t"
using ideduct_restricted_mono[of M _ t M']
unfolding intruder_deduct_hom_def
by fast

subsection ‹Lemmata: GSMP›
lemma GSMP_disjoint_empty[simp]:
  "GSMP_disjoint {} A Sec" "GSMP_disjoint A {} Sec"
unfolding GSMP_disjoint_def GSMP_def by fastforce+

lemma GSMP_mono:
  assumes "N  M"
  shows "GSMP N  GSMP M"
using SMP_mono[OF assms] unfolding GSMP_def by fast

lemma GSMP_SMP_mono:
  assumes "SMP N  SMP M"
  shows "GSMP N  GSMP M"
using assms unfolding GSMP_def by fast

lemma GSMP_subterm:
  assumes "t  GSMP M" "t'  t"
  shows "t'  GSMP M"
using SMP.Subterm[of t M t'] ground_subterm[of t t'] assms unfolding GSMP_def by auto

lemma GSMP_subterms: "subtermsset (GSMP M) = GSMP M"
using GSMP_subterm[of _ M] by blast

lemma GSMP_Ana_key:
  assumes "t  GSMP M" "Ana t = (K,T)" "k  set K"
  shows "k  GSMP M"
using SMP.Ana[of t M K T k] Ana_keys_fv[of t K T] assms unfolding GSMP_def by auto

lemma GSMP_append[simp]: "GSMP (trmslst (A@B)) = GSMP (trmslst A)  GSMP (trmslst B)"
using SMP_union[of "trmslst A" "trmslst B"] trmslst_append[of A B] unfolding GSMP_def by auto

lemma GSMP_union: "GSMP (A  B) = GSMP A  GSMP B"
using SMP_union[of A B] unfolding GSMP_def by auto

lemma GSMP_Union: "GSMP (trmslst A) = (l. GSMP (trms_projlst l A))"
proof -
  define P where "P  (λl. trms_projlst l A)"
  define Q where "Q  trmslst A"
  have "SMP (l. P l) = (l. SMP (P l))" "Q = (l. P l)"
    unfolding P_def Q_def by (metis SMP_Union, metis trmslst_union)
  hence "GSMP Q = (l. GSMP (P l))" unfolding GSMP_def by auto
  thus ?thesis unfolding P_def Q_def by metis
qed

lemma in_GSMP_in_proj: "t  GSMP (trmslst A)  n. t  GSMP (trms_projlst n A)"
using GSMP_Union[of A] by blast

lemma in_proj_in_GSMP: "t  GSMP (trms_projlst n A)  t  GSMP (trmslst A)"
using GSMP_Union[of A] by blast

lemma GSMP_disjointE:
  assumes A: "GSMP_disjoint (trms_projlst n A) (trms_projlst m A) Sec"
  shows "GSMP (trms_projlst n A)  GSMP (trms_projlst m A)  Sec  {m. {} c m}"
using assms unfolding GSMP_disjoint_def by auto

lemma GSMP_disjoint_term:
  assumes "GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec"
  shows "t  GSMP (trms_projlst l 𝒜)  t  GSMP (trms_projlst l' 𝒜)  t  Sec  {} c t"
using assms unfolding GSMP_disjoint_def by blast

lemma GSMP_wt_subst_subset:
  assumes "t  GSMP (M set )" "wtsubst " "wftrms (subst_range )"
  shows "t  GSMP M"
using SMP_wt_subst_subset[OF _ assms(2,3), of t M] assms(1) unfolding GSMP_def by simp

lemma GSMP_wt_substI:
  assumes "t  M" "wtsubst I" "wftrms (subst_range I)" "interpretationsubst I"
  shows "t  I  GSMP M"
proof -
  have "t  SMP M" using assms(1) by auto
  hence *: "t  I  SMP M" using SMP.Substitution assms(2,3) wf_trm_subst_range_iff[of I] by simp
  moreover have "fv (t  I) = {}"
    using assms(1) interpretation_grounds_all'[OF assms(4)]
    by auto
  ultimately show ?thesis unfolding GSMP_def by simp
qed

lemma GSMP_disjoint_subset:
  assumes "GSMP_disjoint L R S" "L'  L" "R'  R"
  shows "GSMP_disjoint L' R' S"
using assms(1) SMP_mono[OF assms(2)] SMP_mono[OF assms(3)]
by (auto simp add: GSMP_def GSMP_disjoint_def)

lemma GSMP_disjoint_fst_specific_not_snd_specific:
  assumes "GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec" "l  l'"
  and "proj_specific l m 𝒜 Sec"
  shows "¬proj_specific l' m 𝒜 Sec"
using assms by (fastforce simp add: GSMP_disjoint_def proj_specific_def)

lemma GSMP_disjoint_snd_specific_not_fst_specific:
  assumes "GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec"
  and "proj_specific l' m 𝒜 Sec"
  shows "¬proj_specific l m 𝒜 Sec"
using assms by (auto simp add: GSMP_disjoint_def proj_specific_def)

lemma GSMP_disjoint_intersection_not_specific:
  assumes "GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec"
  and "t  Sec  {} c t"
  shows "¬proj_specific l t 𝒜 Sec" "¬proj_specific l t 𝒜 Sec"
using assms by (auto simp add: GSMP_disjoint_def proj_specific_def)

subsection ‹Lemmata: Intruder Knowledge and Declassification›
lemma ik_proj_subst_GSMP_subset:
  assumes I: "wtsubst I" "wftrms (subst_range I)" "interpretationsubst I"
  shows "ikst (proj_unl n A) set I  GSMP (trms_projlst n A)"
proof
  fix t assume "t  ikst (proj_unl n A) set I"
  hence *: "t  trms_projlst n A set I" by auto
  then obtain s where "s  trms_projlst n A" "t = s  I" by auto
  hence "t  SMP (trms_projlst n A)" using SMP_I I(1,2) wf_trm_subst_range_iff[of I] by simp
  moreover have "fv t = {}"
    using * interpretation_grounds_all'[OF I(3)]
    by auto
  ultimately show "t  GSMP (trms_projlst n A)" unfolding GSMP_def by simp
qed

lemma declassified_proj_ik_subset: "declassifiedlst A I  ikst (proj_unl n A) set I"
proof (induction A)
  case (Cons a A) thus ?case
    using proj_ik_append[of n "[a]" A] by (auto simp add: declassifiedlst_def)
qed (simp add: declassifiedlst_def)

lemma declassified_proj_GSMP_subset:
  assumes I: "wtsubst I" "wftrms (subst_range I)" "interpretationsubst I"
  shows "declassifiedlst A I  GSMP (trms_projlst n A)"
by (rule subset_trans[OF declassified_proj_ik_subset ik_proj_subst_GSMP_subset[OF I]])

lemma declassified_subterms_proj_GSMP_subset:
  assumes I: "wtsubst I" "wftrms (subst_range I)" "interpretationsubst I"
  shows "subtermsset (declassifiedlst A I)  GSMP (trms_projlst n A)"
proof
  fix t assume t: "t  subtermsset (declassifiedlst A I)"
  then obtain t' where t': "t'  declassifiedlst A I" "t  t'" by moura
  hence "t'  GSMP (trms_projlst n A)" using declassified_proj_GSMP_subset[OF assms] by blast
  thus "t  GSMP (trms_projlst n A)"
    using SMP.Subterm[of t' "trms_projlst n A" t] ground_subterm[OF _ t'(2)] t'(2)
    unfolding GSMP_def by fast
qed

lemma declassified_secrets_subset:
  assumes A: "n m. n  m  GSMP_disjoint (trms_projlst n A) (trms_projlst m A) Sec"
  and I: "wtsubst I" "wftrms (subst_range I)" "interpretationsubst I"
  shows "declassifiedlst A I  Sec  {m. {} c m}"
using declassified_proj_GSMP_subset[OF I] A at_least_2_labels
unfolding GSMP_disjoint_def by blast

lemma declassified_subterms_secrets_subset:
  assumes A: "n m. n  m  GSMP_disjoint (trms_projlst n A) (trms_projlst m A) Sec"
  and I: "wtsubst I" "wftrms (subst_range I)" "interpretationsubst I"
  shows "subtermsset (declassifiedlst A I)  Sec  {m. {} c m}"
using declassified_subterms_proj_GSMP_subset[OF I, of A label_witness1]
      declassified_subterms_proj_GSMP_subset[OF I, of A label_witness2]
      A at_least_2_labels
unfolding GSMP_disjoint_def by fast

lemma declassified_proj_eq: "declassifiedlst A I = declassifiedlst (proj n A) I"
unfolding declassifiedlst_def proj_def by auto

lemma declassified_append: "declassifiedlst (A@B) I = declassifiedlst A I  declassifiedlst B I"
unfolding declassifiedlst_def by auto

lemma declassified_prefix_subset: "prefix A B  declassifiedlst A I  declassifiedlst B I"
using declassified_append unfolding prefix_def by auto

subsection ‹Lemmata: Homogeneous and Heterogeneous Terms›
lemma proj_specific_secrets_anti_mono:
  assumes "proj_specific l t 𝒜 Sec" "Sec'  Sec"
  shows "proj_specific l t 𝒜 Sec'"
using assms unfolding proj_specific_def by fast

lemma heterogeneous_secrets_anti_mono:
  assumes "heterogeneouslst t 𝒜 Sec" "Sec'  Sec"
  shows "heterogeneouslst t 𝒜 Sec'"
using assms proj_specific_secrets_anti_mono unfolding heterogeneouslst_def by metis

lemma homogeneous_secrets_mono:
  assumes "homogeneouslst t 𝒜 Sec'" "Sec'  Sec"
  shows "homogeneouslst t 𝒜 Sec"
using assms heterogeneous_secrets_anti_mono by blast

lemma heterogeneous_supterm:
  assumes "heterogeneouslst t 𝒜 Sec" "t  t'"
  shows "heterogeneouslst t' 𝒜 Sec"
proof -
  obtain l1 l2 s1 s2 where *:
      "l1  l2"
      "s1  t" "proj_specific l1 s1 𝒜 Sec"
      "s2  t" "proj_specific l2 s2 𝒜 Sec"
    using assms(1) unfolding heterogeneouslst_def by moura
  thus ?thesis
    using term.order_trans[OF *(2) assms(2)] term.order_trans[OF *(4) assms(2)]
    by (auto simp add: heterogeneouslst_def)
qed

lemma homogeneous_subterm:
  assumes "homogeneouslst t 𝒜 Sec" "t'  t"
  shows "homogeneouslst t' 𝒜 Sec"
by (metis assms heterogeneous_supterm)

lemma proj_specific_subterm:
  assumes "t  t'" "proj_specific l t' 𝒜 Sec"
  shows "proj_specific l t 𝒜 Sec  t  Sec  {} c t"
using GSMP_subterm[OF _ assms(1)] assms(2) by (auto simp add: proj_specific_def)

lemma heterogeneous_term_is_Fun:
  assumes "heterogeneouslst t A S" shows "f T. t = Fun f T"
using assms by (cases t) (auto simp add: GSMP_def heterogeneouslst_def proj_specific_def)

lemma proj_specific_is_homogeneous:
  assumes 𝒜: "l l'. l  l'  GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec"
  and t: "proj_specific l m 𝒜 Sec"
  shows "homogeneouslst m 𝒜 Sec"
proof
  assume "heterogeneouslst m 𝒜 Sec"
  then obtain s l' where s: "s  subterms m" "proj_specific l' s 𝒜 Sec" "l  l'"
    unfolding heterogeneouslst_def by moura
  hence "s  GSMP (trms_projlst l 𝒜)" "s  GSMP (trms_projlst l' 𝒜)"
    using t by (auto simp add: GSMP_def proj_specific_def)
  hence "s  Sec  {} c s"
    using 𝒜 s(3) by (auto simp add: GSMP_disjoint_def)
  thus False using s(2) by (auto simp add: proj_specific_def)
qed

lemma deduct_synth_homogeneous:
  assumes "{} c t"
  shows "homogeneouslst t 𝒜 Sec"
proof -
  have "s  subterms t. {} c s" using deduct_synth_subterm[OF assms] by auto
  thus ?thesis unfolding heterogeneouslst_def proj_specific_def by auto
qed

lemma GSMP_proj_is_homogeneous:
  assumes "l l'. l  l'  GSMP_disjoint (trms_projlst l A) (trms_projlst l' A) Sec"
  and "t  GSMP (trms_projlst l A)" "t  Sec"
  shows "homogeneouslst t A Sec"
proof
  assume "heterogeneouslst t A Sec"
  then obtain s l' where s: "s  subterms t" "proj_specific l' s A Sec" "l  l'"
    unfolding heterogeneouslst_def by moura
  hence "s  GSMP (trms_projlst l A)" "s  GSMP (trms_projlst l' A)"
    using assms by (auto simp add: GSMP_def proj_specific_def)
  hence "s  Sec  {} c s" using assms(1) s(3) by (auto simp add: GSMP_disjoint_def)
  thus False using s(2) by (auto simp add: proj_specific_def)
qed

lemma homogeneous_is_not_proj_specific:
  assumes "homogeneouslst m 𝒜 Sec"
  shows "l::'lbl. ¬proj_specific l m 𝒜 Sec"
proof -
  let ?P = "λl s. proj_specific l s 𝒜 Sec"
  have "l1 l2. s1subterms m. s2subterms m. (l1  l2  (¬?P l1 s1  ¬?P l2 s2))"
    using assms heterogeneouslst_def by metis
  then obtain l1 l2 where "l1  l2" "¬?P l1 m  ¬?P l2 m"
    by (metis term.order_refl at_least_2_labels)
  thus ?thesis by metis
qed

lemma secrets_are_homogeneous:
  assumes "s  Sec. P s  (s'  subterms s. {} c s'  s'  Sec)" "s  Sec" "P s"
  shows "homogeneouslst s 𝒜 Sec"
using assms by (auto simp add: heterogeneouslst_def proj_specific_def)

lemma GSMP_is_homogeneous:
  assumes 𝒜: "l l'. l  l'  GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec"
  and t: "t  GSMP (trmslst 𝒜)" "t  Sec"
  shows "homogeneouslst t 𝒜 Sec"
proof -
  obtain n where n: "t  GSMP (trms_projlst n 𝒜)" using in_GSMP_in_proj[OF t(1)] by moura
  show ?thesis using GSMP_proj_is_homogeneous[OF 𝒜 n t(2)] by metis
qed

lemma GSMP_intersection_is_homogeneous:
  assumes 𝒜: "l l'. l  l'  GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec"
    and t: "t  GSMP (trms_projlst l 𝒜)  GSMP (trms_projlst l' 𝒜)" "l  l'"
  shows "homogeneouslst t 𝒜 Sec"
proof -
  define M where "M  GSMP (trms_projlst l 𝒜)"
  define M' where "M'  GSMP (trms_projlst l' 𝒜)"

  have t_in: "t  M  M'" "t  GSMP (trmslst 𝒜)"
    using t(1) in_proj_in_GSMP[of t _ 𝒜]
    unfolding M_def M'_def by blast+

  have "M  M'  Sec  {m. {} c m}"
    using 𝒜 GSMP_disjointE[of l 𝒜 l' Sec] t(2)
    unfolding M_def M'_def by presburger
  moreover have "subtermsset (M  M') = M  M'"
    using GSMP_subterms unfolding M_def M'_def by blast
  ultimately have *: "subtermsset (M  M')  Sec  {m. {} c m}"
    by blast

  show ?thesis
  proof (cases "t  Sec")
    case True thus ?thesis
      using * secrets_are_homogeneous[of Sec "λt. t  M  M'", OF _ _ t_in(1)]
      by fast
  qed (metis GSMP_is_homogeneous[OF 𝒜 t_in(2)])
qed

lemma GSMP_is_homogeneous':
  assumes 𝒜: "l l'. l  l'  GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec"
  and t: "t  GSMP (trmslst 𝒜)"
         "t  Sec - {GSMP (trms_projlst l1 𝒜)  GSMP (trms_projlst l2 𝒜) | l1 l2. l1  l2}"
  shows "homogeneouslst t 𝒜 Sec"
using GSMP_is_homogeneous[OF 𝒜 t(1)] GSMP_intersection_is_homogeneous[OF 𝒜] t(2)
by blast

lemma declassified_secrets_are_homogeneous:
  assumes 𝒜: "l l'. l  l'  GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec"
    and: "wtsubst " "wftrms (subst_range )" "interpretationsubst "
    and s: "s  declassifiedlst 𝒜 "
  shows "homogeneouslst s 𝒜 Sec"
proof -
  have s_in: "s  GSMP (trmslst 𝒜)"
    using declassified_proj_GSMP_subset[OF, of 𝒜 label_witness1]
          in_proj_in_GSMP[of s label_witness1 𝒜] s
    by blast

  show ?thesis
  proof (cases "s  Sec")
    case True thus ?thesis
      using declassified_subterms_secrets_subset[OF 𝒜 ℐ]
            secrets_are_homogeneous[of Sec "λs. s  declassifiedlst 𝒜 ", OF _ _ s]
      by fast
  qed (metis GSMP_is_homogeneous[OF 𝒜 s_in])
qed

lemma Ana_keys_homogeneous:
  assumes 𝒜: "l l'. l  l'  GSMP_disjoint (trms_projlst l 𝒜) (trms_projlst l' 𝒜) Sec"
  and t: "t  GSMP (trmslst 𝒜)"
  and k: "Ana t = (K,T)" "k  set K"
         "k  Sec - {GSMP (trms_projlst l1 𝒜)  GSMP (trms_projlst l2 𝒜) | l1 l2. l1  l2}"
  shows "homogeneouslst k 𝒜 Sec"
proof (cases "k  {GSMP (trms_projlst l1 𝒜)  GSMP (trms_projlst l2 𝒜) | l1 l2. l1  l2}")
  case False
  hence "k  Sec" using k(3) by fast
  moreover have "k  GSMP (trmslst 𝒜)"
    using t SMP.Ana[OF _ k(1,2)] Ana_keys_fv[OF k(1)] k(2)
    unfolding GSMP_def by auto
  ultimately show ?thesis using GSMP_is_homogeneous[OF 𝒜, of k] by metis
qed (use GSMP_intersection_is_homogeneous[OF 𝒜] in blast)

subsection ‹Lemmata: Intruder Deduction Equivalences›
lemma deduct_if_hom_deduct: "M;A;S hom m  M  m"
using deduct_if_restricted_deduct unfolding intruder_deduct_hom_def by blast

lemma hom_deduct_if_hom_ik:
  assumes "M;A;Sec hom m" "m  M. homogeneouslst m A Sec  m  GSMP (trmslst A)"
  shows "homogeneouslst m A Sec  m  GSMP (trmslst A)"
proof -
  let ?Q = "λm. homogeneouslst m A Sec  m  GSMP (trmslst A)"
  have "?Q t'" when "?Q t" "t'  t" for t t'
    using homogeneous_subterm[OF _ that(2)] GSMP_subterm[OF _ that(2)] that(1)
    by blast
  thus ?thesis
    using assms(1) restricted_deduct_if_restricted_ik[OF _ assms(2)]
    unfolding intruder_deduct_hom_def
    by blast
qed

lemma deduct_hom_if_synth:
  assumes hom: "homogeneouslst m 𝒜 Sec" "m  GSMP (trmslst 𝒜)"
  and m: "M c m"
  shows "M; 𝒜; Sec hom m"
proof -
  let ?Q = "λm. homogeneouslst m 𝒜 Sec  m  GSMP (trmslst 𝒜)"
  have "?Q t'" when "?Q t" "t'  t" for t t'
    using homogeneous_subterm[OF _ that(2)] GSMP_subterm[OF _ that(2)] that(1)
    by blast
  thus ?thesis
    using assms deduct_restricted_if_synth[of ?Q]
    unfolding intruder_deduct_hom_def
    by blast
qed

lemma hom_deduct_if_deduct:
  assumes 𝒜: "par_comp 𝒜 Sec"
  and M: "mM. homogeneouslst m 𝒜 Sec  m  GSMP (trmslst 𝒜)"
  and m: "M  m" "m  GSMP (trmslst 𝒜)"
shows "M; 𝒜; Sec hom m"
proof -
  let ?P = "λx. homogeneouslst x 𝒜 Sec  x  GSMP (trmslst 𝒜)"

  have GSMP_hom: "homogeneouslst t 𝒜 Sec" when "t  GSMP (trmslst 𝒜)" for t
    using 𝒜 GSMP_is_homogeneous[of 𝒜 Sec t]
          secrets_are_homogeneous[of Sec "λx. True" t 𝒜] that
    unfolding par_comp_def by blast

  have P_Ana: "?P k" when "?P t" "Ana t = (K, T)" "k  set K" for t K T k
    using GSMP_Ana_key[OF _ that(2,3), of "trmslst 𝒜"] 𝒜 that GSMP_hom
    by presburger

  have P_subterm: "?P t'" when "?P t" "t'  t" for t t'
    using GSMP_subterm[of _ "trmslst 𝒜"] homogeneous_subterm[of _ 𝒜 Sec] that
    by blast

  have P_m: "?P m"
    using GSMP_hom[OF m(2)] m(2)
    by metis

  show ?thesis
    using restricted_deduct_if_deduct'[OF M _ _ m(1) P_m] P_Ana P_subterm
    unfolding intruder_deduct_hom_def
    by fast
qed


subsection ‹Lemmata: Deduction Reduction of Parallel Composable Constraints›
lemma par_comp_hom_deduct:
  assumes 𝒜: "par_comp 𝒜 Sec"
  and M: "l. m  M l. homogeneouslst m 𝒜 Sec"
         "l. M l  GSMP (trms_projlst l 𝒜)"
         "l. Discl  M l"
         "Discl  Sec  {m. {} c m}"
  and Sec: "l. s  Sec - Discl. ¬(M l; 𝒜; Sec hom s)"
  and t: "l. M l; 𝒜; Sec hom t"
  shows "t  Sec - Discl" (is ?A)
        "l. t  GSMP (trms_projlst l 𝒜)  M l; 𝒜; Sec hom t" (is ?B)
proof -
  have M': "l. m  M l. m  GSMP (trmslst 𝒜)"
  proof (intro allI ballI)
    fix l m show "m  M l  m  GSMP (trmslst 𝒜)" using M(2) in_proj_in_GSMP[of m l 𝒜] by blast
  qed

  show ?A ?B using t
  proof (induction t rule: intruder_deduct_hom_induct)
    case (AxiomH t)
    then obtain lt where t_in_proj_ik: "t  M lt" by moura
    show t_not_Sec: "t  Sec - Discl"
    proof
      assume "t  Sec - Discl"
      hence "l. ¬(M l;𝒜;Sec hom t)" using Sec by auto
      thus False using intruder_deduct_hom_AxiomH[OF t_in_proj_ik] by metis
    qed
    
    have 1: "l. t  M l  t  GSMP (trms_projlst l 𝒜)"
      using M(2,3) AxiomH by auto
  
    have 3: "l1 l2. l1  l2  t  GSMP (trms_projlst l1 𝒜)  GSMP (trms_projlst l2 𝒜)
                               {} c t  t  Discl"
      using 𝒜 t_not_Sec by (auto simp add: par_comp_def GSMP_disjoint_def)
  
    have 4: "homogeneouslst t 𝒜 Sec" "t  GSMP (trmslst 𝒜)" using M(1) M' t_in_proj_ik by auto
  
    { fix l assume "t  Discl"
      hence "t  M l" using M(3) by auto
      hence "M l; 𝒜; Sec hom t" by auto
    } hence 5: "l. t  Discl  M l; 𝒜; Sec hom t" by metis
    
    show "l. t  GSMP (trms_projlst l 𝒜)  M l; 𝒜; Sec hom t"
      by (metis (lifting) Int_iff empty_subsetI
          1 3 4 5 t_in_proj_ik
          intruder_deduct_hom_AxiomH[of t _ 𝒜 Sec]
          deduct_hom_if_synth[of t 𝒜 Sec "{}"]
          ideduct_hom_mono[of "{}" 𝒜 Sec t])
  next
    case (ComposeH T f)
    show "l. Fun f T  GSMP (trms_projlst l 𝒜)  M l; 𝒜; Sec hom Fun f T"
    proof (intro allI impI)
      fix l
      assume "Fun f T  GSMP (trms_projlst l 𝒜)"
      hence "t. t  set T  t  GSMP (trms_projlst l 𝒜)"
        using GSMP_subterm[OF _ subtermeqI''] by auto
      thus "M l; 𝒜; Sec hom Fun f T"
        using ComposeH.IH(2) intruder_deduct_hom_ComposeH[OF ComposeH.hyps(1,2) _ ComposeH.hyps(4,5)]
        by simp
    qed
    thus "Fun f T  Sec - Discl"
      using Sec ComposeH.hyps(5) trmslst_union[of 𝒜] GSMP_Union[of 𝒜]
      by (metis (no_types, lifting) UN_iff)
  next
    case (DecomposeH t K T ti)
    have ti_subt: "ti  t" using Ana_subterm[OF DecomposeH.hyps(2)] ti  set T by auto
    have t: "homogeneouslst t 𝒜 Sec" "t  GSMP (trmslst 𝒜)"
      using DecomposeH.hyps(1) hom_deduct_if_hom_ik M(1) M'
      by auto
    have ti: "homogeneouslst ti 𝒜 Sec" "ti  GSMP (trmslst 𝒜)"
      using intruder_deduct_hom_DecomposeH[OF DecomposeH.hyps] hom_deduct_if_hom_ik M(1) M' by auto
    { fix l assume *: "ti  GSMP (trms_projlst l 𝒜)" "t  GSMP (trms_projlst l 𝒜)"
      hence "k. k  set K  M l;𝒜;Sec hom k"
        using GSMP_Ana_key[OF _ DecomposeH.hyps(2)] DecomposeH.IH(4) by auto
      hence "M l;𝒜;Sec hom ti" "ti  Sec - Discl"
        using Sec DecomposeH.IH(2) *(2)
              intruder_deduct_hom_DecomposeH[OF _ DecomposeH.hyps(2) _ ti  set T]
        by force+
    } moreover {
      fix l1 l2 assume *: "ti  GSMP (trms_projlst l1 𝒜)" "t  GSMP (trms_projlst l2 𝒜)" "l1  l2"
      have "GSMP_disjoint (trms_projlst l1 𝒜) (trms_projlst l2 𝒜) Sec"
        using *(3) 𝒜 by (simp add: par_comp_def)
      hence "ti  Sec  {m. {} c m}"
        using GSMP_subterm[OF *(2) ti_subt] *(1) by (auto simp add: GSMP_disjoint_def)
      moreover have "k. k  set K  M l2;𝒜;Sec hom k"
        using *(2) GSMP_Ana_key[OF _ DecomposeH.hyps(2)] DecomposeH.IH(4) by auto
      ultimately have "ti  Sec - Discl" "{} c ti  ti  Discl"
        using Sec DecomposeH.IH(2) *(2)
              intruder_deduct_hom_DecomposeH[OF _ DecomposeH.hyps(2) _ ti  set T]
         by (metis (lifting), metis (no_types, lifting) DiffI Un_iff mem_Collect_eq)
      hence "M l1;𝒜;Sec hom ti" "M l2;𝒜;Sec hom ti" "ti  Sec - Discl"
        using M(3,4) deduct_hom_if_synth[THEN ideduct_hom_mono] ti
        by (meson intruder_deduct_hom_AxiomH empty_subsetI subsetCE)+
    } moreover have
        "l. ti  GSMP (trms_projlst l 𝒜)"
        "l. t  GSMP (trms_projlst l 𝒜)"
      using in_GSMP_in_proj[of _ 𝒜] ti(2) t(2) by presburger+
    ultimately show
        "ti  Sec - Discl"
        "l. ti  GSMP (trms_projlst l 𝒜)  M l; 𝒜; Sec hom ti"
      by (metis (no_types, lifting))+
  qed
qed

lemma par_comp_deduct_proj:
  assumes 𝒜: "par_comp 𝒜 Sec"
  and M: "l. mM l. homogeneouslst m 𝒜 Sec"
         "l. M l  GSMP (trms_projlst l 𝒜)"
         "l. Discl  M l"
  and t: "(l. M l)  t" "t  GSMP (trms_projlst l 𝒜)"
  and Discl: "Discl  Sec  {m. {} c m}"
  shows "M l  t  (s  Sec - Discl. l. M l  s)"
using t
proof (induction t rule: intruder_deduct_induct)
  case (Axiom t)
  then obtain l' where t_in_ik_proj: "t  M l'" by moura
  show ?case
  proof (cases "t  Sec - Discl  {} c t")
    case True
    note T = True
    show ?thesis
    proof (cases "t  Sec - Discl")
      case True thus ?thesis using intruder_deduct.Axiom[OF t_in_ik_proj] by metis
    next
      case False thus ?thesis using T ideduct_mono[of "{}" t] by auto
    qed
  next
    case False
    hence "t  Sec - Discl" "¬{} c t" "t  GSMP (trms_projlst l 𝒜)" using Axiom by auto
    hence "(l'. l  l'  t  GSMP (trms_projlst l' 𝒜))  t  Discl"
      using 𝒜 unfolding GSMP_disjoint_def par_comp_def by auto
    hence "(l'. l  l'  t  GSMP (trms_projlst l' 𝒜))  t  M l  {} c t" using M by auto
    thus ?thesis using Axiom deduct_if_synth[THEN ideduct_mono] t_in_ik_proj
      by (metis (no_types, lifting) False M(2) intruder_deduct.Axiom subsetCE) 
  qed
next
  case (Compose T f)
  hence "Fun f T  GSMP (trms_projlst l 𝒜)" using Compose.prems by auto
  hence "t. t  set T  t  GSMP (trms_projlst l 𝒜)" unfolding GSMP_def by auto
  hence IH: "t. t  set T  M l  t  (s  Sec - Discl. l. M l  s)"
    using Compose.IH by auto
  show ?case
  proof (cases "t  set T. M l  t")
    case True thus ?thesis by (metis intruder_deduct.Compose[OF Compose.hyps(1,2)])
  qed (metis IH)
next
  case (Decompose t K T ti)
  have hom_ik: "l. mM l. homogeneouslst m 𝒜 Sec  m  GSMP (trmslst 𝒜)"
  proof (intro allI ballI conjI)
    fix l m assume m: "m  M l"
    thus "homogeneouslst m 𝒜 Sec" using M(1) by simp
    show "m  GSMP (trmslst 𝒜)" using in_proj_in_GSMP[of m l 𝒜] M(2) m by blast
  qed

  have par_comp_unfold:
      "l1 l2. l1  l2  GSMP_disjoint (trms_projlst l1 𝒜) (trms_projlst l2 𝒜) Sec"
    using 𝒜 by (auto simp add: par_comp_def)

  note ti_GSMP = in_proj_in_GSMP[OF Decompose.prems(1)]

  have "l. M l; 𝒜; Sec hom ti"
    using intruder_deduct.Decompose[OF Decompose.hyps]
          hom_deduct_if_deduct[OF 𝒜, of "l. M l"] hom_ik ti_GSMP (* ti_hom *)
    by blast
  hence "(M l; 𝒜; Sec hom ti)  (s  Sec-Discl. l. M l;𝒜;Sec hom s)"
    using par_comp_hom_deduct(2)[OF 𝒜 M Discl(1)] Decompose.prems(1)
    by blast
  thus ?case using deduct_if_hom_deduct[of _ 𝒜 Sec] by auto
qed


subsection ‹Theorem: Parallel Compositionality for Labeled Constraints›
lemma par_comp_prefix: assumes "par_comp (A@B) M" shows "par_comp A M"
proof -
  let ?L = "λl. trms_projlst l A  trms_projlst l B"
  have "l1 l2. l1  l2  GSMP_disjoint (?L l1) (?L l2) M"
    using assms unfolding par_comp_def
    by (metis trmsst_append proj_append(2) unlabel_append)
  hence "l1 l2. l1  l2  GSMP_disjoint (trms_projlst l1 A) (trms_projlst l2 A) M"
    using SMP_union by (auto simp add: GSMP_def GSMP_disjoint_def)
  thus ?thesis using assms unfolding par_comp_def by blast
qed

theorem par_comp_constr_typed:
  assumes 𝒜: "par_comp 𝒜 Sec"
  and: "  unlabel 𝒜" "interpretationsubst " "wtsubst " "wftrms (subst_range )"
  shows "(l. (  proj_unl l 𝒜))  (𝒜'. prefix 𝒜' 𝒜  (strand_leakslst 𝒜' Sec ))"
proof -
  let ?L = "λ𝒜'. t  Sec - declassifiedlst 𝒜' . l. {}; proj_unl l 𝒜'@[Send t]d "
  have "{}; unlabel 𝒜d " usingby (simp add: constr_sem_d_def)
  with 𝒜 have "(l. {}; proj_unl l 𝒜d )  (𝒜'. prefix 𝒜' 𝒜  ?L 𝒜')"
  proof (induction "unlabel 𝒜" arbitrary: 𝒜 rule: List.rev_induct)
    case Nil
    hence "𝒜 = []" using unlabel_nil_only_if_nil by simp
    thus ?case by auto
  next
    case (snoc b B 𝒜)
    hence disj: "l1 l2. l1  l2  GSMP_disjoint (trms_projlst l1 𝒜) (trms_projlst l2 𝒜) Sec"
      by (auto simp add: par_comp_def)

    obtain a A n where a: "𝒜 = A@[a]" "a = (ln n, b)  a = (, b)"
      using unlabel_snoc_inv[OF snoc.hyps(2)[symmetric]] by moura
    hence A: "𝒜 = A@[(ln n, b)]  𝒜 = A@[(, b)]" by metis

    have 1: "B = unlabel A" using a snoc.hyps(2) unlabel_append[of A "[a]"] by auto
    have 2: "par_comp A Sec" using par_comp_prefix snoc.prems(1) a by metis
    have 3: "{}; unlabel Ad " by (metis 1 snoc.prems(2) snoc.hyps(2) strand_sem_split(3))
    have IH: "(l. {}; proj_unl l Ad )  (𝒜'. prefix 𝒜' A  ?L 𝒜')"
      by (rule snoc.hyps(1)[OF 1 2 3])

    show ?case
    proof (cases "l. {}; proj_unl l Ad ")
      case False
      then obtain 𝒜' where 𝒜': "prefix 𝒜' A" "?L 𝒜'" by (metis IH)
      hence "prefix 𝒜' (A@[a])" using a prefix_prefix[of _ A "[a]"] by simp
      thus ?thesis using 𝒜'(2) a by auto
    next
      case True
      note IH' = True
      show ?thesis
      proof (cases b)
        case (Send t)
        hence "ikst (unlabel A) set   t  "
          using a {}; unlabel 𝒜d  strand_sem_split(2)[of "{}" "unlabel A" "unlabel [a]" ]
                unlabel_append[of A "[a]"]
          by auto
        hence *: "(l. (ikst (proj_unl l A) set ))  t  "
          using proj_ik_union_is_unlabel_ik image_UN by metis 

        have "ikst (proj_unl l 𝒜) = ikst (proj_unl l A)" for l
          using Send A 
          by (metis append_Nil2 ikst.simps(3) proj_unl_cons(3) proj_nil(2)
                    singleton_lst_proj(1,2) proj_ik_append)
        hence **: "ikst (proj_unl l A) set   GSMP (trms_projlst l 𝒜)" for l
          using ik_proj_subst_GSMP_subset[OF(3,4,2), of _ 𝒜]
          by auto

        note Discl =
          declassified_proj_ik_subset[of A ]
          declassified_proj_GSMP_subset[OF(3,4,2), of A]
          declassified_secrets_subset[OF disj ℐ(3,4,2)]
          declassified_append[of A "[a]" ]

        have Sec: "ground Sec"
          using 𝒜 by (auto simp add: par_comp_def)

        have "mikst (proj_unl l 𝒜) set . homogeneouslst m 𝒜 Sec  m  Sec-declassifiedlst A "
             "mikst (proj_unl l 𝒜) set . m  GSMP (trmslst 𝒜)"
             "ikst (proj_unl l 𝒜) set   GSMP (trms_projlst l 𝒜)"
          for l
          using declassified_secrets_are_homogeneous[OF disj ℐ(3,4,2)]
                GSMP_proj_is_homogeneous[OF disj]
                ik_proj_subst_GSMP_subset[OF(3,4,2), of _ 𝒜]
          apply (metis (no_types, lifting) Diff_iff Discl(4) UnCI a(1) subsetCE)
          using ik_proj_subst_GSMP_subset[OF(3,4,2), of _ 𝒜]
                GSMP_Union[of 𝒜]
          by auto
        moreover have "ikst (proj_unl l [a]) = {}" for l
          using Send proj_ikst_is_proj_rcv_set[of _ "[a]"] a(2) by auto
        ultimately have M:
            "l. mikst (proj_unl l A) set . homogeneouslst m 𝒜 Sec  m  Sec-declassifiedlst A "
            "l. ikst (proj_unl l A) set   GSMP (trms_projlst l 𝒜)"
          using a(1) proj_ik_append[of _ A "[a]"] by auto

        have prefix_A: "prefix A 𝒜" using A by auto

        have "s   = s"
          when "s  Sec" for s
          using that Sec by auto
        hence leakage_case: "{}; proj_unl l A@[Send s]d "
          when "s  Sec - declassifiedlst A " "ikst (proj_unl l A) set   s" for l s
          using that strand_sem_append(2) IH' by auto

        have proj_deduct_case_n:
            "m. m  n  {}; proj_unl m (A@[a])d "
            "ikst (proj_unl n A) set   t    {}; proj_unl n (A@[a])d "
          when "a = (ln n, Send t)"
          using that IH' proj_append(2)[of _ A]
          by auto

        have proj_deduct_case_star:
            "{}; proj_unl l (A@[a])d "
          when "a = (, Send t)" "ikst (proj_unl l A) set   t  " for l
          using that IH' proj_append(2)[of _ A] 
          by auto

        show ?thesis
        proof (cases "l. m  ikst (proj_unl l A) set . m  Sec - declassifiedlst A ")
          case True
          then obtain l s where ls: "s  Sec - declassifiedlst A " "ikst (proj_unl l A) set   s"
            using intruder_deduct.Axiom by metis
          thus ?thesis using leakage_case prefix_A by blast
        next
          case False
          hence M': "l. mikst (proj_unl l A) set . homogeneouslst m 𝒜 Sec" using M(1) by blast

          note deduct_proj_lemma =
              par_comp_deduct_proj[OF snoc.prems(1) M' M(2) _ *, of "declassifiedlst A " n]

          from a(2) show ?thesis
          proof
            assume "a = (ln n, b)"
            hence "a = (ln n, Send t)" "t    GSMP (trms_projlst n 𝒜)"
              using Send a(1) trms_projlst_append[of n A "[a]"]
                    GSMP_wt_substI[OF _ ℐ(3,4,2)]
              by (metis, force)
            hence
                "a = (ln n, Send t)"
                "m. m  n  {}; proj_unl m (A@[a])d "
                "ikst (proj_unl n A) set   t    {}; proj_unl n (A@[a])d "
                "t    GSMP (trms_projlst n 𝒜)"
              using proj_deduct_case_n
              by auto
            hence "(l. {}; proj_unl l 𝒜d ) 
                   (s  Sec-declassifiedlst A . l. ikst (proj_unl l A) set   s)"
              using deduct_proj_lemma A a Discl
              by fast
            thus ?thesis using leakage_case prefix_A by metis
          next
            assume "a = (, b)"
            hence ***: "a = (, Send t)" "t    GSMP (trms_projlst l 𝒜)" for l
              using Send a(1) GSMP_wt_substI[OF _ ℐ(3,4,2)]
              by (metis, force)
            hence "t    Sec - declassifiedlst A  
                   t    declassifiedlst A  
                   t    {m. {} c m}"
              using snoc.prems(1) a(1) at_least_2_labels
              unfolding par_comp_def GSMP_disjoint_def
              by blast
            thus ?thesis
            proof (elim disjE)
              assume "t    Sec - declassifiedlst A "
              hence "s  Sec - declassifiedlst A . l. ikst (proj_unl l A) set   s"
                using deduct_proj_lemma ***(2) A a Discl
                by blast
              thus ?thesis using prefix_A leakage_case by blast
            next
              assume "t    declassifiedlst A "
              hence "ikst (proj_unl l A) set   t  " for l
                using intruder_deduct.Axiom Discl(1) by blast
              thus ?thesis using proj_deduct_case_star[OF ***(1)] a(1) by fast
            next
              assume "t    {m. {} c m}"
              hence "M  t  " for M using ideduct_mono[OF deduct_if_synth] by blast
              thus ?thesis using IH' a(1) ***(1) by fastforce
            qed
          qed
        qed
      next
        case (Receive t)
        hence "{}; proj_unl l 𝒜d " for l
          using IH' a proj_append(2)[of l A "[a]"]
          unfolding unlabel_def proj_def by auto
        thus ?thesis by metis
      next
        case (Equality ac t t')
        hence *: "M; [Equality ac t t']d " for M
          using a {}; unlabel 𝒜d  unlabel_append[of A "[a]"]
          by auto
        show ?thesis
          using a proj_append(2)[of _ A "[a]"] Equality
                strand_sem_append(2)[OF _ *] IH'
          unfolding unlabel_def proj_def by auto
      next
        case (Inequality X F)
        hence *: "M; [Inequality X F]d " for M
          using a {}; unlabel 𝒜d  unlabel_append[of A "[a]"]
          by auto
        show ?thesis
          using a proj_append(2)[of _ A "[a]"] Inequality
                strand_sem_append(2)[OF _ *] IH'
          unfolding unlabel_def proj_def by auto
      qed
    qed
  qed
  thus ?thesis using(1) unfolding strand_leakslst_def by (simp add: constr_sem_d_def)
qed

theorem par_comp_constr:
  assumes 𝒜: "par_comp 𝒜 Sec" "typing_cond (unlabel 𝒜)"
  and: "  unlabel 𝒜" "interpretationsubst "
  shows "τ. interpretationsubst τ  wtsubst τ  wftrms (subst_range τ)  (τ  unlabel 𝒜) 
              ((l. (τ  proj_unl l 𝒜))  (𝒜'. prefix 𝒜' 𝒜  (strand_leakslst 𝒜' Sec τ)))"
proof -
  from 𝒜(2) have *:
      "wfst {} (unlabel 𝒜)"
      "fvst (unlabel 𝒜)  bvarsst (unlabel 𝒜) = {}"
      "tfrst (unlabel 𝒜)"
      "wftrms (trmsst (unlabel 𝒜))"
      "Ana_invar_subst (ikst (unlabel 𝒜)  assignment_rhsst (unlabel 𝒜))"
    unfolding typing_cond_def tfrst_def by metis+

  obtain τ whereτ: "τ  unlabel 𝒜" "interpretationsubst τ" "wtsubst τ" "wftrms (subst_range τ)"
    using wt_attack_if_tfr_attack_d[OF * ℐ(2,1)] by metis

  show ?thesis using par_comp_constr_typed[OF 𝒜(1)τ]τ by auto
qed


subsection ‹Theorem: Parallel Compositionality for Labeled Protocols›
subsubsection ‹Definitions: Labeled Protocols›
text ‹
  We state our result on the level of protocol traces (i.e., the constraints reachable in a
  symbolic execution of the actual protocol). Hence, we do not need to convert protocol strands
  to intruder constraints in the following well-formedness definitions.
›
definition wflsts::"('fun,'var,'lbl) labeled_strand set  bool" where
  "wflsts 𝒮  (𝒜  𝒮. wflst {} 𝒜)  (𝒜  𝒮. 𝒜'  𝒮. fvlst 𝒜  bvarslst 𝒜' = {})"

definition wflsts'::"('fun,'var,'lbl) labeled_strand set  ('fun,'var,'lbl) labeled_strand  bool"
where
  "wflsts' 𝒮 𝒜  (𝒜'  𝒮. wfst (wfrestrictedvarslst 𝒜) (unlabel 𝒜')) 
                 (𝒜'  𝒮. 𝒜''  𝒮. fvlst 𝒜'  bvarslst 𝒜'' = {}) 
                 (𝒜'  𝒮. fvlst 𝒜'  bvarslst 𝒜 = {}) 
                 (𝒜'  𝒮. fvlst 𝒜  bvarslst 𝒜' = {})"

definition typing_cond_prot where
  "typing_cond_prot 𝒫 
    wflsts 𝒫 
    tfrset ((trmslst ` 𝒫)) 
    wftrms ((trmslst ` 𝒫)) 
    (𝒜  𝒫. list_all tfrstp (unlabel 𝒜)) 
    Ana_invar_subst ((ikst ` unlabel ` 𝒫)  (assignment_rhsst ` unlabel ` 𝒫))"

definition par_comp_prot where
  "par_comp_prot 𝒫 Sec 
    (l1 l2. l1  l2 
      GSMP_disjoint (𝒜  𝒫. trms_projlst l1 𝒜) (𝒜  𝒫. trms_projlst l2 𝒜) Sec) 
    ground Sec  (s  Sec. s'  subterms s. {} c s'  s'  Sec) 
    typing_cond_prot 𝒫"


subsubsection ‹Lemmata: Labeled Protocols›
lemma wflsts_eqs_wflsts'[simp]: "wflsts S = wflsts' S []"
unfolding wflsts_def wflsts'_def unlabel_def by auto

lemma par_comp_prot_impl_par_comp:
  assumes "par_comp_prot 𝒫 Sec" "𝒜  𝒫"
  shows "par_comp 𝒜 Sec"
proof -
  have *: "l1 l2. l1  l2 
              GSMP_disjoint (𝒜  𝒫. trms_projlst l1 𝒜) (𝒜  𝒫. trms_projlst l2 𝒜) Sec"
    using assms(1) unfolding par_comp_prot_def by metis
  { fix l1 l2::'lbl assume **: "l1  l2"
    hence ***: "GSMP_disjoint (𝒜  𝒫. trms_projlst l1 𝒜) (𝒜  𝒫. trms_projlst l2 𝒜) Sec"
      using * by auto
    have "GSMP_disjoint (trms_projlst l1 𝒜) (trms_projlst l2 𝒜) Sec"
      using GSMP_disjoint_subset[OF ***] assms(2) by auto
  } hence "l1 l2. l1  l2  GSMP_disjoint (trms_projlst l1 𝒜) (trms_projlst l2 𝒜) Sec" by metis
  thus ?thesis using assms unfolding par_comp_prot_def par_comp_def by metis
qed

lemma typing_cond_prot_impl_typing_cond:
  assumes "typing_cond_prot 𝒫" "𝒜  𝒫"
  shows "typing_cond (unlabel 𝒜)"
proof -
  have 1: "wfst {} (unlabel 𝒜)" "fvlst 𝒜  bvarslst 𝒜 = {}"
    using assms unfolding typing_cond_prot_def wflsts_def by auto

  have "tfrset ((trmslst ` 𝒫))"
       "wftrms ((trmslst ` 𝒫))"
       "trmslst 𝒜  (trmslst ` 𝒫)"
       "SMP (trmslst 𝒜) - Var`𝒱  SMP ((trmslst ` 𝒫)) - Var`𝒱"
    using assms SMP_mono[of "trmslst 𝒜" "(trmslst ` 𝒫)"]
    unfolding typing_cond_prot_def
    by (metis, metis, auto)
  hence 2: "tfrset (trmslst 𝒜)" and 3: "wftrms (trmslst 𝒜)"
    unfolding tfrset_def by (meson subsetD)+

  have 4: "list_all tfrstp (unlabel 𝒜)" using assms unfolding typing_cond_prot_def by auto

  have "subtermsset (ikst (unlabel 𝒜)  assignment_rhsst (unlabel 𝒜)) 
        subtermsset ((ikst ` unlabel ` 𝒫)  (assignment_rhsst ` unlabel ` 𝒫))"
    using assms(2) by auto
  hence 5: "Ana_invar_subst (ikst (unlabel 𝒜)  assignment_rhsst (unlabel 𝒜))"
    using assms SMP_mono unfolding typing_cond_prot_def Ana_invar_subst_def by (meson subsetD)

  show ?thesis using 1 2 3 4 5 unfolding typing_cond_def tfrst_def by blast
qed


subsubsection ‹Theorem: Parallel Compositionality for Labeled Protocols›
definition component_prot where
  "component_prot n P  (l  P. s  set l. is_LabelN n s  is_LabelS s)"

definition composed_prot where
  "composed_prot 𝒫i  {𝒜. n. proj n 𝒜  𝒫i n}"

definition component_secure_prot where
  "component_secure_prot n P Sec attack  (𝒜  P. suffix [(ln n, Send (Fun attack []))] 𝒜  
     (τ. (interpretationsubst τ  wtsubst τ  wftrms (subst_range τ)) 
            ¬(τ  proj_unl n 𝒜) 
            (𝒜'. prefix 𝒜' 𝒜 
                    (t  Sec-declassifiedlst 𝒜' τ. ¬(τ  proj_unl n 𝒜'@[Send t])))))"

definition component_leaks where
  "component_leaks n 𝒜 Sec  (𝒜' τ. interpretationsubst τ  wtsubst τ  wftrms (subst_range τ) 
      prefix 𝒜' 𝒜  (t  Sec - declassifiedlst 𝒜' τ. (τ  proj_unl n 𝒜'@[Send t])))"

definition unsat where
  "unsat 𝒜  (. interpretationsubst   ¬(  unlabel 𝒜))"

theorem par_comp_constr_prot:
  assumes P: "P = composed_prot Pi" "par_comp_prot P Sec" "n. component_prot n (Pi n)"
  and left_secure: "component_secure_prot n (Pi n) Sec attack"
  shows "𝒜  P. suffix [(ln n, Send (Fun attack []))] 𝒜 
                  unsat 𝒜  (m. n  m  component_leaks m 𝒜 Sec)"
proof -
  { fix 𝒜 𝒜' assume 𝒜: "𝒜 = 𝒜'@[(ln n, Send (Fun attack []))]" "𝒜  P"
    let ?P = "𝒜' τ. interpretationsubst τ  wtsubst τ  wftrms (subst_range τ)  prefix 𝒜' 𝒜 
                   (t  Sec - declassifiedlst 𝒜' τ. m. n  m  (τ  proj_unl m 𝒜'@[Send t]))"
    have tcp: "typing_cond_prot P" using P(2) unfolding par_comp_prot_def by simp
    have par_comp: "par_comp 𝒜 Sec" "typing_cond (unlabel 𝒜)"
      using par_comp_prot_impl_par_comp[OF P(2) 𝒜(2)]
            typing_cond_prot_impl_typing_cond[OF tcp 𝒜(2)]
      by metis+
  
    have "unlabel (proj n 𝒜) = proj_unl n 𝒜" "proj_unl n 𝒜 = proj_unl n (proj n 𝒜)"
         "A. A  Pi n  proj n A = A" 
         "proj n 𝒜 = (proj n 𝒜')@[(ln n, Send (Fun attack []))]"
      using P(1,3) 𝒜 by (auto simp add: proj_def unlabel_def component_prot_def composed_prot_def)
    moreover have "proj n 𝒜  Pi n"
      using P(1) 𝒜 unfolding composed_prot_def by blast
    moreover {
      fix A assume "prefix A 𝒜"
      hence *: "prefix (proj n A) (proj n 𝒜)" unfolding proj_def prefix_def by force
      hence "proj_unl n A = proj_unl n (proj n A)"
            "I. declassifiedlst A I = declassifiedlst (proj n A) I"
        unfolding proj_def declassifiedlst_def by auto
      hence "B. prefix B (proj n 𝒜)  proj_unl n A = proj_unl n B 
                 (I. declassifiedlst A I = declassifiedlst B I)"
        using * by metis
        
    }
    ultimately have *: 
        "τ. interpretationsubst τ  wtsubst τ  wftrms (subst_range τ) 
                  ¬(τ  proj_unl n 𝒜)  (𝒜'. prefix 𝒜' 𝒜 
                        (t  Sec - declassifiedlst 𝒜' τ. ¬(τ  proj_unl n 𝒜'@[Send t])))"
      using left_secure unfolding component_secure_prot_def composed_prot_def suffix_def by metis
    { fix  assume: "interpretationsubst " "  unlabel 𝒜"
      obtain τ whereτ:
          "interpretationsubst τ" "wtsubst τ" "wftrms (subst_range τ)"
          "𝒜'. prefix 𝒜' 𝒜  (strand_leakslst 𝒜' Sec τ)"
        using par_comp_constr[OF par_comp ℐ(2,1)] * by moura
      hence "𝒜'. prefix 𝒜' 𝒜  (t  Sec - declassifiedlst 𝒜' τ. m.
                  n  m  (τ  proj_unl m 𝒜'@[Send t]))"
        usingτ(4) * unfolding strand_leakslst_def by metis
      hence ?P usingτ(1,2,3) by auto
    } hence "unsat 𝒜  (m. n  m  component_leaks m 𝒜 Sec)"
      by (metis unsat_def component_leaks_def)
  } thus ?thesis unfolding suffix_def by metis
qed

end


subsection ‹Automated GSMP Disjointness›
locale labeled_typed_model' = typed_model' arity public Ana Γ +
  labeled_typed_model arity public Ana Γ label_witness1 label_witness2
  for arity::"'fun  nat"
    and public::"'fun  bool"
    and Ana::"('fun,(('fun,'atom::finite) term_type × nat)) term
               (('fun,(('fun,'atom) term_type × nat)) term list
                 × ('fun,(('fun,'atom) term_type × nat)) term list)"
    and Γ::"('fun,(('fun,'atom) term_type × nat)) term  ('fun,'atom) term_type"
    and label_witness1 label_witness2::'lbl
begin

lemma GSMP_disjointI:
  fixes A' A B B'::"('fun, ('fun, 'atom) term × nat) term list"
  defines "f  λM. {t  δ | t δ. t  M  wtsubst δ  wftrms (subst_range δ)  fv (t  δ) = {}}"
    and "δ  var_rename (max_var_set (fvset (set A)))"
  assumes A'_wf: "list_all (wftrm' arity) A'"
    and B'_wf: "list_all (wftrm' arity) B'"
    and A_inst: "has_all_wt_instances_of Γ (set A') (set A)"
    and B_inst: "has_all_wt_instances_of Γ (set B') (set (B list δ))"
    and A_SMP_repr: "finite_SMP_representation arity Ana Γ A"
    and B_SMP_repr: "finite_SMP_representation arity Ana Γ (B list δ)"
    and AB_trms_disj:
      "t  set A. s  set (B list δ). Γ t = Γ s  mgu t s  None 
        (intruder_synth' public arity {} t  intruder_synth' public arity {} s) 
        ((u  Sec. is_wt_instance_of_cond Γ t u)  (u  Sec. is_wt_instance_of_cond Γ s u))"
    and Sec_wf: "wftrms Sec"
  shows "GSMP_disjoint (set A') (set B') ((f Sec) - {m. {} c m})"
proof -
  have A_wf: "wftrms (set A)" and B_wf: "wftrms (set (B list δ))"
    and A'_wf': "wftrms (set A')" and B'_wf': "wftrms (set B')"
    using finite_SMP_representationD[OF A_SMP_repr]
          finite_SMP_representationD[OF B_SMP_repr]
          A'_wf B'_wf
    unfolding wftrms_code[symmetric] wftrm_code[symmetric] list_all_iff by blast+

  have AB_fv_disj: "fvset (set A)  fvset (set (B list δ)) = {}"
    using var_rename_fv_set_disjoint'[of "set A" "set B", unfolded δ_def[symmetric]] by simp

  have "GSMP_disjoint (set A) (set (B list δ)) ((f Sec) - {m. {} c m})"
    using ground_SMP_disjointI[OF AB_fv_disj A_SMP_repr B_SMP_repr Sec_wf AB_trms_disj]
    unfolding GSMP_def GSMP_disjoint_def f_def by blast
  moreover have "SMP (set A')  SMP (set A)" "SMP (set B')  SMP (set (B list δ))"
    using SMP_I'[OF A'_wf' A_wf A_inst] SMP_SMP_subset[of "set A'" "set A"]
          SMP_I'[OF B'_wf' B_wf B_inst] SMP_SMP_subset[of "set B'" "set (B list δ)"]
    by blast+
  ultimately show ?thesis unfolding GSMP_def GSMP_disjoint_def by auto
qed

end

end

Theory Labeled_Stateful_Strands

(*
(C) Copyright Andreas Viktor Hess, DTU, 2018-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Labeled_Stateful_Strands.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹Labeled Stateful Strands›
theory Labeled_Stateful_Strands
imports Stateful_Strands Labeled_Strands
begin

subsection ‹Definitions›
text‹Syntax for stateful strand labels›
abbreviation Star_step ("⟨⋆, _") where
  "⟨⋆, (s::('a,'b) stateful_strand_step)  (, s)"

abbreviation LabelN_step ("_, _") where
  "(l::'a), (s::('b,'c) stateful_strand_step)  (ln l, s)"


text‹Database projection›
abbreviation dbproj where "dbproj l D  filter (λd. fst d = l) D"

text‹The type of labeled stateful strands›
type_synonym ('a,'b,'c) labeled_stateful_strand_step = "'c strand_label × ('a,'b) stateful_strand_step"
type_synonym ('a,'b,'c) labeled_stateful_strand = "('a,'b,'c) labeled_stateful_strand_step list"

text‹Dual strands›
fun duallsstp::"('a,'b,'c) labeled_stateful_strand_step  ('a,'b,'c) labeled_stateful_strand_step"
where
  "duallsstp (l,send⟨t) = (l,receive⟨t)"
| "duallsstp (l,receive⟨t) = (l,send⟨t)"
| "duallsstp x = x"

definition duallsst::"('a,'b,'c) labeled_stateful_strand  ('a,'b,'c) labeled_stateful_strand"
where
  "duallsst  map duallsstp"

text‹Substitution application›
fun subst_apply_labeled_stateful_strand_step::
  "('a,'b,'c) labeled_stateful_strand_step  ('a,'b) subst 
   ('a,'b,'c) labeled_stateful_strand_step"
  (infix "lsstp" 51) where
  "(l,s) lsstp θ  = (l,s sstp θ)"

definition subst_apply_labeled_stateful_strand::
  "('a,'b,'c) labeled_stateful_strand  ('a,'b) subst  ('a,'b,'c) labeled_stateful_strand"
  (infix "lsst" 51) where
  "S lsst θ  map (λx. x lsstp θ) S"

text‹Definitions lifted from stateful strands›
abbreviation wfrestrictedvarslsst where "wfrestrictedvarslsst S  wfrestrictedvarssst (unlabel S)"

abbreviation iklsst where "iklsst S  iksst (unlabel S)"

abbreviation dblsst where "dblsst S  dbsst (unlabel S)"
abbreviation db'lsst where "db'lsst S  db'sst (unlabel S)"

abbreviation trmslsst where "trmslsst S  trmssst (unlabel S)"
abbreviation trms_projlsst where "trms_projlsst n S  trmssst (proj_unl n S)"

abbreviation varslsst where "varslsst S  varssst (unlabel S)"
abbreviation vars_projlsst where "vars_projlsst n S  varssst (proj_unl n S)"

abbreviation bvarslsst where "bvarslsst S  bvarssst (unlabel S)"
abbreviation fvlsst where "fvlsst S  fvsst (unlabel S)"

text‹Labeled set-operations›
fun setopslsstp where
  "setopslsstp (i,insert⟨t,s) = {(i,t,s)}"
| "setopslsstp (i,delete⟨t,s) = {(i,t,s)}"
| "setopslsstp (i,_: t  s) = {(i,t,s)}"
| "setopslsstp (i,_⟨∨≠: _ ∨∉: F') = ((λ(t,s). (i,t,s)) ` set F')"
| "setopslsstp _ = {}"

definition setopslsst where
  "setopslsst S  (setopslsstp ` set S)"


subsection ‹Minor Lemmata›
lemma subst_lsst_nil[simp]: "[] lsst δ = []"
by (simp add: subst_apply_labeled_stateful_strand_def)

lemma subst_lsst_cons: "a#A lsst δ = (a lsstp δ)#(A lsst δ)"
by (simp add: subst_apply_labeled_stateful_strand_def)

lemma subst_lsst_singleton: "[(l,s)] lsst δ = [(l,s sstp δ)]"
by (simp add: subst_apply_labeled_stateful_strand_def)

lemma subst_lsst_append: "A@B lsst δ = (A lsst δ)@(B lsst δ)"
by (simp add: subst_apply_labeled_stateful_strand_def)

lemma subst_lsst_append_inv:
  assumes "A lsst δ = B1@B2"
  shows "A1 A2. A = A1@A2  A1 lsst δ = B1  A2 lsst δ = B2"
using assms
proof (induction A arbitrary: B1 B2)
  case (Cons a A)
  note prems = Cons.prems
  note IH = Cons.IH
  show ?case
  proof (cases B1)
    case Nil
    then obtain b B3 where "B2 = b#B3" "a lsstp δ = b" "A lsst δ = B3"
      using prems subst_lsst_cons by fastforce
    thus ?thesis by (simp add: Nil subst_apply_labeled_stateful_strand_def)
  next
    case (Cons b B3)
    hence "a lsstp δ = b" "A lsst δ = B3@B2"
      using prems by (simp_all add: subst_lsst_cons)
    thus ?thesis by (metis Cons_eq_appendI Cons IH subst_lsst_cons) 
  qed
qed (metis append_is_Nil_conv subst_lsst_nil)

lemma subst_lsst_member[intro]: "x  set A  x lsstp δ  set (A lsst δ)"
by (metis image_eqI set_map subst_apply_labeled_stateful_strand_def)

lemma subst_lsst_unlabel_cons: "unlabel ((l,b)#A lsst θ) = (b sstp θ)#(unlabel (A lsst θ))"
by (simp add: subst_apply_labeled_stateful_strand_def)

lemma subst_lsst_unlabel: "unlabel (A lsst δ) = unlabel A sst δ"
proof (induction A)
  case (Cons a A)
  then obtain l b where "a = (l,b)" by (metis surj_pair)
  thus ?case
    using Cons
    by (simp add: subst_apply_labeled_stateful_strand_def subst_apply_stateful_strand_def)
qed simp

lemma subst_lsst_unlabel_member[intro]:
  assumes "x  set (unlabel A)"
  shows "x sstp δ  set (unlabel (A lsst δ))"
proof -
  obtain l where x: "(l,x)  set A" using assms unfolding unlabel_def by moura
  thus ?thesis
    using subst_lsst_member
    by (metis unlabel_def in_set_zipE subst_apply_labeled_stateful_strand_step.simps zip_map_fst_snd)
qed

lemma subst_lsst_prefix:
  assumes "prefix B (A lsst θ)"
  shows "C. C lsst θ = B  prefix C A"
using assms
proof (induction A rule: List.rev_induct)
  case (snoc a A) thus ?case
  proof (cases "B = A@[a] lsst θ")
    case False thus ?thesis
      using snoc by (auto simp add: subst_lsst_append[of A] subst_lsst_cons)
  qed auto
qed simp

lemma duallsst_nil[simp]: "duallsst [] = []"
by (simp add: duallsst_def)

lemma duallsst_Cons[simp]:
  "duallsst ((l,send⟨t)#A) = (l,receive⟨t)#(duallsst A)"
  "duallsst ((l,receive⟨t)#A) = (l,send⟨t)#(duallsst A)"
  "duallsst ((l,a: t  s)#A) = (l,a: t  s)#(duallsst A)"
  "duallsst ((l,insert⟨t,s)#A) = (l,insert⟨t,s)#(duallsst A)"
  "duallsst ((l,delete⟨t,s)#A) = (l,delete⟨t,s)#(duallsst A)"
  "duallsst ((l,a: t  s)#A) = (l,a: t  s)#(duallsst A)"
  "duallsst ((l,X⟨∨≠: F ∨∉: G)#A) = (l,X⟨∨≠: F ∨∉: G)#(duallsst A)"
by (simp_all add: duallsst_def)

lemma duallsst_append[simp]: "duallsst (A@B) = duallsst A@duallsst B"
by (simp add: duallsst_def)

lemma duallsstp_subst: "duallsstp (s lsstp δ) = (duallsstp s) lsstp δ"
proof -
  obtain l x  where s: "s = (l,x)" by moura
  thus ?thesis by (cases x) (auto simp add: subst_apply_labeled_stateful_strand_def)
qed

lemma duallsst_subst: "duallsst (S lsst δ) = (duallsst S) lsst δ"
proof (induction S)
  case (Cons s S) thus ?case
    using Cons duallsstp_subst[of s δ]
    by (simp add: duallsst_def subst_apply_labeled_stateful_strand_def)
qed (simp add: duallsst_def subst_apply_labeled_stateful_strand_def)

lemma duallsst_subst_unlabel: "unlabel (duallsst (S lsst δ)) = unlabel (duallsst S) sst δ" 
by (metis duallsst_subst subst_lsst_unlabel)

lemma duallsst_subst_cons: "duallsst (a#A lsst σ) = (duallsstp a lsstp σ)#(duallsst (A lsst σ))"
by (metis duallsst_subst list.simps(9) duallsst_def subst_apply_labeled_stateful_strand_def)

lemma duallsst_subst_append: "duallsst (A@B lsst σ) = (duallsst A@duallsst B) lsst σ"
by (metis (no_types) duallsst_subst duallsst_append)

lemma duallsst_subst_snoc: "duallsst (A@[a] lsst σ) = (duallsst A lsst σ)@[duallsstp a lsstp σ]"
by (metis duallsst_def duallsst_subst duallsst_subst_cons list.map(1) map_append
          subst_apply_labeled_stateful_strand_def)

lemma duallsst_memberD:
  assumes "(l,a)  set (duallsst A)"
  shows "b. (l,b)  set A  duallsstp (l,b) = (l,a)"
  using assms
proof (induction A)
  case (Cons c A)
  hence "(l,a)  set (duallsst A)  duallsstp c = (l,a)" unfolding duallsst_def by force
  thus ?case
  proof
    assume "(l,a)  set (duallsst A)" thus ?case using Cons.IH by auto
  next
    assume a: "duallsstp c = (l,a)"
    obtain i b where b: "c = (i,b)" by (metis surj_pair)
    thus ?case using a by (cases b) auto
  qed
qed simp

lemma duallsstp_inv:
  assumes "duallsstp (l, a) = (k, b)"
  shows "l = k"
    and "a = receive⟨t  b = send⟨t"
    and "a = send⟨t  b = receive⟨t"
    and "(t. a = receive⟨t  a = send⟨t)  b = a"
proof -
  show "l = k" using assms by (cases a) auto
  show "a = receive⟨t  b = send⟨t" using assms by (cases a) auto
  show "a = send⟨t  b = receive⟨t" using assms by (cases a) auto
  show "(t. a = receive⟨t  a = send⟨t)  b = a" using assms by (cases a) auto
qed

lemma duallsst_self_inverse: "duallsst (duallsst A) = A"
proof (induction A)
  case (Cons a A)
  obtain l b where "a = (l,b)" by (metis surj_pair)
  thus ?case using Cons by (cases b) auto
qed simp

lemma varssst_unlabel_duallsst_eq: "varslsst (duallsst A) = varslsst A"
proof (induction A)
  case (Cons a A)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  thus ?case using Cons.IH by (cases b) auto
qed simp

lemma fvsst_unlabel_duallsst_eq: "fvlsst (duallsst A) = fvlsst A"
proof (induction A)
  case (Cons a A)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  thus ?case using Cons.IH by (cases b) auto
qed simp

lemma bvarssst_unlabel_duallsst_eq: "bvarslsst (duallsst A) = bvarslsst A"
proof (induction A)
  case (Cons a A)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  thus ?case using Cons.IH by (cases b) simp+
qed simp

lemma varssst_unlabel_Cons: "varslsst ((l,b)#A) = varssstp b  varslsst A"
by (metis unlabel_Cons(1) varssst_Cons)

lemma fvsst_unlabel_Cons: "fvlsst ((l,b)#A) = fvsstp b  fvlsst A"
by (metis unlabel_Cons(1) fvsst_Cons)

lemma bvarssst_unlabel_Cons: "bvarslsst ((l,b)#A) = set (bvarssstp b)  bvarslsst A"
by (metis unlabel_Cons(1) bvarssst_Cons)

lemma bvarslsst_subst: "bvarslsst (A lsst δ) = bvarslsst A"
by (metis subst_lsst_unlabel bvarssst_subst)

lemma duallsst_member:
  assumes "(l,x)  set A"
    and "¬is_Receive x" "¬is_Send x"
  shows "(l,x)  set (duallsst A)"
using assms
proof (induction A)
  case (Cons a A) thus ?case using assms(2,3) by (cases x) (auto simp add: duallsst_def)
qed simp

lemma duallsst_unlabel_member:
  assumes "x  set (unlabel A)"
    and "¬is_Receive x" "¬is_Send x"
  shows "x  set (unlabel (duallsst A))"
using assms duallsst_member[of _ _ A]
  by (meson unlabel_in unlabel_mem_has_label)

lemma duallsst_steps_iff:
  "(l,send⟨t)  set A  (l,receive⟨t)  set (duallsst A)"
  "(l,receive⟨t)  set A  (l,send⟨t)  set (duallsst A)"
  "(l,c: t  s)  set A  (l,c: t  s)  set (duallsst A)"
  "(l,insert⟨t,s)  set A  (l,insert⟨t,s)  set (duallsst A)"
  "(l,delete⟨t,s)  set A  (l,delete⟨t,s)  set (duallsst A)"
  "(l,c: t  s)  set A  (l,c: t  s)  set (duallsst A)"
  "(l,X⟨∨≠: F ∨∉: G)  set A  (l,X⟨∨≠: F ∨∉: G)  set (duallsst A)"
proof (induction A)
  case (Cons a A)
  obtain j b where a: "a = (j,b)" by (metis surj_pair)
  { case 1 thus ?case by (cases b) (simp_all add: Cons.IH(1) a duallsst_def) }
  { case 2 thus ?case by (cases b) (simp_all add: Cons.IH(2) a duallsst_def) }
  { case 3 thus ?case by (cases b) (simp_all add: Cons.IH(3) a duallsst_def) }
  { case 4 thus ?case by (cases b) (simp_all add: Cons.IH(4) a duallsst_def) }
  { case 5 thus ?case by (cases b) (simp_all add: Cons.IH(5) a duallsst_def) }
  { case 6 thus ?case by (cases b) (simp_all add: Cons.IH(6) a duallsst_def) }
  { case 7 thus ?case by (cases b) (simp_all add: Cons.IH(7) a duallsst_def) }
qed (simp_all add: duallsst_def)

lemma duallsst_unlabel_steps_iff:
  "send⟨t  set (unlabel A)  receive⟨t  set (unlabel (duallsst A))"
  "receive⟨t  set (unlabel A)  send⟨t  set (unlabel (duallsst A))"
  "c: t  s  set (unlabel A)  c: t  s  set (unlabel (duallsst A))"
  "insert⟨t,s  set (unlabel A)  insert⟨t,s  set (unlabel (duallsst A))"
  "delete⟨t,s  set (unlabel A)  delete⟨t,s  set (unlabel (duallsst A))"
  "c: t  s  set (unlabel A)  c: t  s  set (unlabel (duallsst A))"
  "X⟨∨≠: F ∨∉: G  set (unlabel A)  X⟨∨≠: F ∨∉: G  set (unlabel (duallsst A))"
using duallsst_steps_iff(1,2)[of _ t A]
      duallsst_steps_iff(3,6)[of _ c t s A]
      duallsst_steps_iff(4,5)[of _ t s A]
      duallsst_steps_iff(7)[of _ X F G A]
by (meson unlabel_in unlabel_mem_has_label)+

lemma duallsst_list_all:
  "list_all is_Receive (unlabel A)  list_all is_Send (unlabel (duallsst A))"
  "list_all is_Send (unlabel A)  list_all is_Receive (unlabel (duallsst A))"
  "list_all is_Equality (unlabel A)  list_all is_Equality (unlabel (duallsst A))"
  "list_all is_Insert (unlabel A)  list_all is_Insert (unlabel (duallsst A))"
  "list_all is_Delete (unlabel A)  list_all is_Delete (unlabel (duallsst A))"
  "list_all is_InSet (unlabel A)  list_all is_InSet (unlabel (duallsst A))"
  "list_all is_NegChecks (unlabel A)  list_all is_NegChecks (unlabel (duallsst A))"
  "list_all is_Assignment (unlabel A)  list_all is_Assignment (unlabel (duallsst A))"
  "list_all is_Check (unlabel A)  list_all is_Check (unlabel (duallsst A))"
  "list_all is_Update (unlabel A)  list_all is_Update (unlabel (duallsst A))"
proof (induct A)
  case (Cons a A)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  { case 1 thus ?case using Cons.hyps(1) a by (cases b) auto }
  { case 2 thus ?case using Cons.hyps(2) a by (cases b) auto }
  { case 3 thus ?case using Cons.hyps(3) a by (cases b) auto }
  { case 4 thus ?case using Cons.hyps(4) a by (cases b) auto }
  { case 5 thus ?case using Cons.hyps(5) a by (cases b) auto }
  { case 6 thus ?case using Cons.hyps(6) a by (cases b) auto }
  { case 7 thus ?case using Cons.hyps(7) a by (cases b) auto }
  { case 8 thus ?case using Cons.hyps(8) a by (cases b) auto }
  { case 9 thus ?case using Cons.hyps(9) a by (cases b) auto }
  { case 10 thus ?case using Cons.hyps(10) a by (cases b) auto }
qed simp_all

lemma duallsst_in_set_prefix_obtain:
  assumes "s  set (unlabel (duallsst A))"
  shows "l B s'. (l,s) = duallsstp (l,s')  prefix (B@[(l,s')]) A"
  using assms
proof (induction A rule: List.rev_induct)
  case (snoc a A)
  obtain i b where a: "a = (i,b)" by (metis surj_pair)
  show ?case using snoc
  proof (cases "s  set (unlabel (duallsst A))")
    case False thus ?thesis
      using a snoc.prems unlabel_append[of "duallsst A" "duallsst [a]"] duallsst_append[of A "[a]"]
      by (cases b) (force simp add: unlabel_def duallsst_def)+
  qed auto
qed simp

lemma duallsst_in_set_prefix_obtain_subst:
  assumes "s  set (unlabel (duallsst (A lsst θ)))"
  shows "l B s'. (l,s) = duallsstp ((l,s') lsstp θ)  prefix ((B lsst θ)@[(l,s') lsstp θ]) (A lsst θ)"
proof -
  obtain B l s' where B: "(l,s) = duallsstp (l,s')" "prefix (B@[(l,s')]) (A lsst θ)"
    using duallsst_in_set_prefix_obtain[OF assms] by moura

  obtain C where C: "C lsst θ = B@[(l,s')]"
    using subst_lsst_prefix[OF B(2)] by moura

  obtain D u where D: "C = D@[(l,u)]" "D lsst θ = B" "[(l,u)] lsst θ = [(l, s')]"
    using subst_lsst_prefix[OF B(2)] subst_lsst_append_inv[OF C(1)]
    by (auto simp add: subst_apply_labeled_stateful_strand_def)

  show ?thesis 
    using B D subst_lsst_cons subst_lsst_singleton
    by (metis (no_types, lifting) nth_append_length)
qed

lemma trmssst_unlabel_duallsst_eq: "trmslsst (duallsst A) = trmslsst A"
proof (induction A)
  case (Cons a A)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  thus ?case using Cons.IH by (cases b) auto
qed simp

lemma trmssst_unlabel_subst_cons:
  "trmslsst ((l,b)#A lsst δ) = trmssstp (b sstp δ)  trmslsst (A lsst δ)"
by (metis subst_lsst_unlabel trmssst_subst_cons unlabel_Cons(1))

lemma trmssst_unlabel_subst:
  assumes "bvarslsst S  subst_domain θ = {}"
  shows "trmslsst (S lsst θ) = trmslsst S set θ"
by (metis trmssst_subst[OF assms] subst_lsst_unlabel)

lemma trmssst_unlabel_subst':
  fixes t::"('a,'b) term" and δ::"('a,'b) subst"
  assumes "t  trmslsst (S lsst δ)"
  shows "s  trmslsst S. X. set X  bvarslsst S  t = s  rm_vars (set X) δ"
using assms
proof (induction S)
  case (Cons a S)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  hence "t  trmslsst (S lsst δ)  t  trmssstp (b sstp δ)" 
    using Cons.prems trmssst_unlabel_subst_cons by fast
  thus ?case
  proof
    assume *: "t  trmssstp (b sstp δ)"
    show ?thesis using trmssstp_subst''[OF *] a by auto
  next
    assume *: "t  trmslsst (S lsst δ)"
    show ?thesis using Cons.IH[OF *] a by auto
  qed
qed simp

lemma trmssst_unlabel_subst'':
  fixes t::"('a,'b) term" and δ θ::"('a,'b) subst"
  assumes "t  trmslsst (S lsst δ) set θ"
  shows "s  trmslsst S. X. set X  bvarslsst S  t = s  rm_vars (set X) δ s θ"
proof -
  obtain s where s: "s  trmslsst (S lsst δ)" "t = s  θ" using assms by moura
  show ?thesis using trmssst_unlabel_subst'[OF s(1)] s(2) by auto
qed

lemma trmssst_unlabel_dual_subst_cons:
  "trmslsst (duallsst (a#A lsst σ)) = (trmssstp (snd a sstp σ))  (trmslsst (duallsst (A lsst σ)))"
proof -
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  thus ?thesis using a duallsst_subst_cons[of a A σ] by (cases b) auto
qed

lemma duallsst_funs_term:
  "(funs_term ` (trmssst (unlabel (duallsst S)))) = (funs_term ` (trmssst (unlabel S)))"
using trmssst_unlabel_duallsst_eq by fast

lemma duallsst_dblsst:
  "db'lsst (duallsst A) = db'lsst A"
proof (induction A)
  case (Cons a A)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  thus ?case using Cons by (cases b) auto
qed simp

lemma dbsst_unlabel_append:
  "db'lsst (A@B) I D = db'lsst B I (db'lsst A I D)"
by (metis dbsst_append unlabel_append)

lemma dbsst_duallsst:
  "db'sst (unlabel (duallsst (T lsst δ)))  D = db'sst (unlabel (T lsst δ))  D"
proof (induction T arbitrary: D)
  case (Cons x T)
  obtain l s where "x = (l,s)" by moura
  thus ?case
    using Cons
    by (cases s) (simp_all add: unlabel_def duallsst_def subst_apply_labeled_stateful_strand_def)  
qed (simp add: unlabel_def duallsst_def subst_apply_labeled_stateful_strand_def)

lemma labeled_list_insert_eq_cases:
  "d  set (unlabel D)  List.insert d (unlabel D) = unlabel (List.insert (i,d) D)"
  "(i,d)  set D  List.insert d (unlabel D) = unlabel (List.insert (i,d) D)"
unfolding unlabel_def
by (metis (no_types, hide_lams) List.insert_def image_eqI list.simps(9) set_map snd_conv,
    metis in_set_insert set_zip_rightD zip_map_fst_snd)

lemma labeled_list_insert_eq_ex_cases:
  "List.insert d (unlabel D) = unlabel (List.insert (i,d) D) 
  (j. (j,d)  set D  List.insert d (unlabel D) = unlabel (List.insert (j,d) D))"
using labeled_list_insert_eq_cases unfolding unlabel_def
by (metis in_set_impl_in_set_zip2 length_map zip_map_fst_snd)

lemma proj_subst: "proj l (A lsst δ) = proj l A lsst δ"
proof (induction A)
  case (Cons a A)
  obtain l b where "a = (l,b)" by (metis surj_pair)
  thus ?case using Cons unfolding proj_def subst_apply_labeled_stateful_strand_def by force
qed simp 

lemma proj_set_subset[simp]:
  "set (proj n A)  set A"
unfolding proj_def by auto

lemma proj_proj_set_subset[simp]:
  "set (proj n (proj m A))  set (proj n A)"
  "set (proj n (proj m A))  set (proj m A)"
  "set (proj_unl n (proj m A))  set (proj_unl n A)"
  "set (proj_unl n (proj m A))  set (proj_unl m A)"
unfolding unlabel_def proj_def by auto

lemma proj_in_set_iff:
  "(ln i, d)  set (proj i D)  (ln i, d)  set D"
  "(, d)  set (proj i D)  (, d)  set D"
unfolding proj_def by auto

lemma proj_list_insert:
  "proj i (List.insert (ln i,d) D) = List.insert (ln i,d) (proj i D)"
  "proj i (List.insert (,d) D) = List.insert (,d) (proj i D)"
  "i  j  proj i (List.insert (ln j,d) D) = proj i D"
unfolding List.insert_def proj_def by auto

lemma proj_filter: "proj i [dD. d  set Di] = [dproj i D. d  set Di]"
by (simp_all add: proj_def conj_commute)

lemma proj_list_Cons:
  "proj i ((ln i,d)#D) = (ln i,d)#proj i D"
  "proj i ((,d)#D) = (,d)#proj i D"
  "i  j  proj i ((ln j,d)#D) = proj i D"
unfolding List.insert_def proj_def by auto

lemma proj_duallsst:
  "proj l (duallsst A) = duallsst (proj l A)"
proof (induction A)
  case (Cons a A)
  obtain k b where "a = (k,b)" by (metis surj_pair)
  thus ?case using Cons unfolding duallsst_def proj_def by (cases b) auto
qed simp

lemma proj_instance_ex:
  assumes B: "b  set B. a  set A. δ. b = a lsstp δ  P δ"
    and b: "b  set (proj l B)"
  shows "a  set (proj l A). δ. b = a lsstp δ  P δ"
proof -
  obtain a δ where a: "a  set A" "b = a lsstp δ" "P δ" using B b proj_set_subset by fast
  obtain k b' where b': "b = (k, b')" "k = (ln l)  k = " using b proj_in_setD by metis
  obtain a' where a': "a = (k, a')" using b'(1) a(2) by (cases a) simp_all
  show ?thesis using a a' b'(2) unfolding proj_def by auto
qed

lemma proj_dbproj:
  "dbproj (ln i) (proj i D) = dbproj (ln i) D"
  "dbproj  (proj i D) = dbproj  D"
  "i  j  dbproj (ln j) (proj i D) = []"
unfolding proj_def by (induct D) auto

lemma dbproj_Cons:
  "dbproj i ((i,d)#D) = (i,d)#dbproj i D"
  "i  j  dbproj j ((i,d)#D) = dbproj j D"
by auto

lemma dbproj_subset[simp]:
  "set (unlabel (dbproj i D))  set (unlabel D)"
unfolding unlabel_def by auto

lemma dbproj_subseq: 
  assumes "Di  set (subseqs (dbproj k D))"
  shows "dbproj k Di = Di" (is ?A)
  and "i  k  dbproj i Di = []" (is "i  k  ?B")
proof -
  have *: "set Di  set (dbproj k D)" using subseqs_powset[of "dbproj k D"] assms by auto
  thus ?A by (metis filter_True filter_set member_filter subsetCE)

  have "j d. (j,d)  set Di  j = k" using * by auto
  moreover have "j d. (j,d)  set (dbproj i Di)  j = i" by auto
  moreover have "j d. (j,d)  set (dbproj i Di)  (j,d)  set Di" by auto
  ultimately show "i  k  ?B" by (metis set_empty subrelI subset_empty)
qed

lemma dbproj_subseq_subset:
  assumes "Di  set (subseqs (dbproj i D))"
  shows "set Di  set D"
by (metis Pow_iff assms filter_set image_eqI member_filter subseqs_powset subsetCE subsetI)

lemma dbproj_subseq_in_subseqs:
  assumes "Di  set (subseqs (dbproj i D))"
  shows "Di  set (subseqs D)"
using assms in_set_subseqs subseq_filter_left subseq_order.dual_order.trans by blast

lemma proj_subseq:
  assumes "Di  set (subseqs (dbproj (ln j) D))" "j  i"
  shows "[dproj i D. d  set Di] = proj i D"
proof -
  have "set Di  set (dbproj (ln j) D)" using subseqs_powset[of "dbproj (ln j) D"] assms by auto
  hence "k d. (k,d)  set Di  k = ln j" by auto
  moreover have "k d. (k,d)  set (proj i D)  k  ln j"
    using assms(2) unfolding proj_def by auto
  ultimately have "d. d  set (proj i D)  d  set Di" by auto
  thus ?thesis by simp
qed

lemma unlabel_subseqsD:
  assumes "A  set (subseqs (unlabel B))"
  shows "C  set (subseqs B). unlabel C = A"
using assms map_subseqs unfolding unlabel_def by (metis imageE set_map) 

lemma unlabel_filter_eq:
  assumes "(j, p)  set A  B. (k, q)  set A  B. p = q  j = k" (is "?P (set A)")
  shows "[dunlabel A. d  snd ` B] = unlabel [dA. d  B]"
using assms unfolding unlabel_def
proof (induction A)
  case (Cons a A)
  have "set A  set (a#A)" "{a}  set (a#A)" by auto
  hence *: "?P (set A)" "?P {a}" using Cons.prems by fast+
  hence IH: "[dmap snd A . d  snd ` B] = map snd [dA . d  B]" using Cons.IH by auto

  { assume "snd a  snd ` B"
    then obtain b where b: "b  B" "snd a = snd b" by moura
    hence "fst a = fst b" using *(2) by auto
    hence "a  B" using b by (metis surjective_pairing)  
  } hence **: "a  B  snd a  snd ` B" by metis

  show ?case by (cases "a  B") (simp add: ** IH)+ 
qed simp

lemma subseqs_mem_dbproj:
  assumes "Di  set (subseqs D)" "list_all (λd. fst d = i) Di"
  shows "Di  set (subseqs (dbproj i D))"
using assms
proof (induction D arbitrary: Di)
  case (Cons di D)
  obtain d j where di: "di = (j,d)" by (metis surj_pair)
  show ?case
  proof (cases "Di  set (subseqs D)")
    case True
    hence "Di  set (subseqs (dbproj i D))" using Cons.IH Cons.prems by auto
    thus ?thesis using subseqs_Cons by auto
  next
    case False
    then obtain Di' where Di': "Di = di#Di'" using Cons.prems(1)
      by (metis (mono_tags, lifting) Un_iff imageE set_append set_map subseqs.simps(2)) 
    hence "Di'  set (subseqs D)" using Cons.prems(1) False
      by (metis (no_types, lifting) UnE imageE list.inject set_append set_map subseqs.simps(2)) 
    hence "Di'  set (subseqs (dbproj i D))" using Cons.IH Cons.prems Di' by auto
    moreover have "i = j" using Di' di Cons.prems(2) by auto
    hence "dbproj i (di#D) = di#dbproj i D" by (simp add: di)
    ultimately show ?thesis using Di'
      by (metis (no_types, lifting) UnCI image_eqI set_append set_map subseqs.simps(2)) 
  qed
qed simp

lemma unlabel_subst: "unlabel S sst δ = unlabel (S lsst δ)"
unfolding unlabel_def subst_apply_stateful_strand_def subst_apply_labeled_stateful_strand_def 
by auto

lemma subterms_subst_lsst:
  assumes "x  fvset (trmslsst S). (f. σ x = Fun f [])  (y. σ x = Var y)"
    and "bvarslsst S  subst_domain σ = {}"
  shows "subtermsset (trmslsst (S lsst σ)) = subtermsset (trmslsst S) set σ"
using subterms_subst''[OF assms(1)] trmssst_subst[OF assms(2)] unlabel_subst[of S σ]
by simp

lemma subterms_subst_lsst_ik:
  assumes "x  fvset (iklsst S). (f. σ x = Fun f [])  (y. σ x = Var y)"
  shows "subtermsset (iklsst (S lsst σ)) = subtermsset (iklsst S) set σ"
using subterms_subst''[OF assms(1)] iksst_subst[of "unlabel S" σ] unlabel_subst[of S σ]
by simp

lemma labeled_stateful_strand_subst_comp:
  assumes "range_vars δ  bvarslsst S = {}"
  shows "S lsst δ s θ = (S lsst δ) lsst θ"
using assms
proof (induction S)
  case (Cons s S)
  obtain l x where s: "s = (l,x)" by (metis surj_pair)
  hence IH: "S lsst δ s θ = (S lsst δ) lsst θ" using Cons by auto

  have "x sstp δ s θ = (x sstp δ) sstp θ"
    using s Cons.prems stateful_strand_step_subst_comp[of δ x θ] by auto
  thus ?case using s IH by (simp add: subst_apply_labeled_stateful_strand_def)
qed simp

lemma sst_vars_proj_subset[simp]:
  "fvsst (proj_unl n A)  fvsst (unlabel A)"
  "bvarssst (proj_unl n A)  bvarssst (unlabel A)"
  "varssst (proj_unl n A)  varssst (unlabel A)"
using varssst_is_fvsst_bvarssst[of "unlabel A"]
      varssst_is_fvsst_bvarssst[of "proj_unl n A"]
unfolding unlabel_def proj_def by auto

lemma trmssst_proj_subset[simp]:
  "trmssst (proj_unl n A)  trmssst (unlabel A)" (is ?A)
  "trmssst (proj_unl m (proj n A))  trmssst (proj_unl n A)" (is ?B)
  "trmssst (proj_unl m (proj n A))  trmssst (proj_unl m A)" (is ?C)
proof -
  show ?A unfolding unlabel_def proj_def by auto
  show ?B using trmssst_mono[OF proj_proj_set_subset(4)] by metis
  show ?C using trmssst_mono[OF proj_proj_set_subset(3)] by metis
qed

lemma trmssst_unlabel_prefix_subset:
  "trmssst (unlabel A)  trmssst (unlabel (A@B))" (is ?A)
  "trmssst (proj_unl n A)  trmssst (proj_unl n (A@B))" (is ?B)
using trmssst_mono[of "proj_unl n A" "proj_unl n (A@B)"]
unfolding unlabel_def proj_def by auto

lemma trmssst_unlabel_suffix_subset:
  "trmssst (unlabel B)  trmssst (unlabel (A@B))"
  "trmssst (proj_unl n B)  trmssst (proj_unl n (A@B))"
using trmssst_mono[of "proj_unl n B" "proj_unl n (A@B)"]
unfolding unlabel_def proj_def by auto

lemma setopslsstpD:
  assumes p: "p  setopslsstp a"
  shows "fst p = fst a" (is ?P)
    and "is_Update (snd a)  is_InSet (snd a)  is_NegChecks (snd a)" (is ?Q)
proof -
  obtain l k p' a' where a: "p = (l,p')" "a = (k,a')" by (metis surj_pair)
  show ?P using p a by (cases a') auto
  show ?Q using p a by (cases a') auto
qed

lemma setopslsst_nil[simp]:
  "setopslsst [] = {}"
by (simp add: setopslsst_def)

lemma setopslsst_cons[simp]:
  "setopslsst (x#S) = setopslsstp x  setopslsst S"
by (simp add: setopslsst_def)

lemma setopssst_proj_subset:
  "setopssst (proj_unl n A)  setopssst (unlabel A)"
  "setopssst (proj_unl m (proj n A))  setopssst (proj_unl n A)"
  "setopssst (proj_unl m (proj n A))  setopssst (proj_unl m A)"
unfolding unlabel_def proj_def
proof (induction A)
  case (Cons a A)
  obtain l b where lb: "a = (l,b)" by moura
  { case 1 thus ?case using Cons.IH lb by (cases b) (auto simp add: setopssst_def) }
  { case 2 thus ?case using Cons.IH lb by (cases b) (auto simp add: setopssst_def) }
  { case 3 thus ?case using Cons.IH lb by (cases b) (auto simp add: setopssst_def) }
qed simp_all

lemma setopssst_unlabel_prefix_subset:
  "setopssst (unlabel A)  setopssst (unlabel (A@B))"
  "setopssst (proj_unl n A)  setopssst (proj_unl n (A@B))"
unfolding unlabel_def proj_def
proof (induction A)
  case (Cons a A)
  obtain l b where lb: "a = (l,b)" by moura
  { case 1 thus ?case using Cons.IH lb by (cases b) (auto simp add: setopssst_def) }
  { case 2 thus ?case using Cons.IH lb by (cases b) (auto simp add: setopssst_def) }
qed (simp_all add: setopssst_def)

lemma setopssst_unlabel_suffix_subset:
  "setopssst (unlabel B)  setopssst (unlabel (A@B))"
  "setopssst (proj_unl n B)  setopssst (proj_unl n (A@B))"
unfolding unlabel_def proj_def
proof (induction A)
  case (Cons a A)
  obtain l b where lb: "a = (l,b)" by moura
  { case 1 thus ?case using Cons.IH lb by (cases b) (auto simp add: setopssst_def) }
  { case 2 thus ?case using Cons.IH lb by (cases b) (auto simp add: setopssst_def) }
qed simp_all

lemma setopslsst_proj_subset:
  "setopslsst (proj n A)  setopslsst A"
  "setopslsst (proj m (proj n A))  setopslsst (proj n A)"
unfolding proj_def setopslsst_def by auto

lemma setopslsst_prefix_subset:
  "setopslsst A  setopslsst (A@B)"
  "setopslsst (proj n A)  setopslsst (proj n (A@B))"
unfolding proj_def setopslsst_def by auto

lemma setopslsst_suffix_subset:
  "setopslsst B  setopslsst (A@B)"
  "setopslsst (proj n B)  setopslsst (proj n (A@B))"
unfolding proj_def setopslsst_def by auto

lemma setopslsst_mono:
  "set M  set N  setopslsst M  setopslsst N"
by (auto simp add: setopslsst_def)

lemma trmssst_unlabel_subset_if_no_label:
  "¬list_ex (is_LabelN l) A  trmslsst (proj l A)  trmslsst (proj l' A)"
by (rule trmssst_mono[OF proj_subset_if_no_label(2)[of l A l']])

lemma setopssst_unlabel_subset_if_no_label:
  "¬list_ex (is_LabelN l) A  setopssst (proj_unl l A)  setopssst (proj_unl l' A)"
by (rule setopssst_mono[OF proj_subset_if_no_label(2)[of l A l']])

lemma setopslsst_proj_subset_if_no_label:
  "¬list_ex (is_LabelN l) A  setopslsst (proj l A)  setopslsst (proj l' A)"
by (rule setopslsst_mono[OF proj_subset_if_no_label(1)[of l A l']])

lemma setopslsstp_subst_cases[simp]:
  "setopslsstp ((l,send⟨t) lsstp δ) = {}"
  "setopslsstp ((l,receive⟨t) lsstp δ) = {}"
  "setopslsstp ((l,ac: s  t) lsstp δ) = {}"
  "setopslsstp ((l,insert⟨t,s) lsstp δ) = {(l,t  δ,s  δ)}"
  "setopslsstp ((l,delete⟨t,s) lsstp δ) = {(l,t  δ,s  δ)}"
  "setopslsstp ((l,ac: t  s) lsstp δ) = {(l,t  δ,s  δ)}"
  "setopslsstp ((l,X⟨∨≠: F ∨∉: F') lsstp δ) =
    ((λ(t,s). (l,t  rm_vars (set X) δ,s  rm_vars (set X) δ)) ` set F')" (is "?A = ?B")
proof -
  have "?A = (λ(t,s). (l,t,s)) ` set (F' pairs rm_vars (set X) δ)" by auto
  thus "?A = ?B" unfolding subst_apply_pairs_def by auto
qed simp_all

lemma setopslsstp_subst:
  assumes "set (bvarssstp (snd a))  subst_domain θ = {}"
  shows "setopslsstp (a lsstp θ) = (λp. (fst a,snd p p θ)) ` setopslsstp a"
proof -
  obtain l a' where a: "a = (l,a')" by (metis surj_pair)
  show ?thesis
  proof (cases a')
    case (NegChecks X F G)
    hence *: "rm_vars (set X) θ = θ" using a assms rm_vars_apply'[of θ "set X"] by auto
    have "setopslsstp (a lsstp θ) = (λp. (fst a, p)) ` set (G pairs θ)"
      using * NegChecks a  by auto
    moreover have "setopslsstp a = (λp. (fst a, p)) ` set G" using NegChecks a by simp
    hence "(λp. (fst a,snd p p θ)) ` setopslsstp a = (λp. (fst a, p p θ)) ` set G"
      by (metis (mono_tags, lifting) image_cong image_image snd_conv)
    hence "(λp. (fst a,snd p p θ)) ` setopslsstp a = (λp. (fst a, p)) ` (set G pset θ)"
      unfolding case_prod_unfold by auto
    ultimately show ?thesis by (simp add: subst_apply_pairs_def) 
  qed (use a in simp_all)
qed

lemma setopslsstp_subst':
  assumes "set (bvarssstp (snd a))  subst_domain θ = {}"
  shows "setopslsstp (a lsstp θ) = (λ(i,p). (i,p p θ)) ` setopslsstp a"
using setopslsstp_subst[OF assms] setopslsstpD(1) unfolding case_prod_unfold
by (metis (mono_tags, lifting) image_cong)

lemma setopslsst_subst:
  assumes "bvarslsst S  subst_domain θ = {}"
  shows "setopslsst (S lsst θ) = (λp. (fst p,snd p p θ)) ` setopslsst S"
using assms
proof (induction S)
  case (Cons a S)
  have "bvarslsst S  subst_domain θ = {}" and *: "set (bvarssstp (snd a))  subst_domain θ = {}"
    using Cons.prems by auto
  hence IH: "setopslsst (S lsst θ) = (λp. (fst p,snd p p θ)) ` setopslsst S"
    using Cons.IH by auto
  show ?case
    using setopslsstp_subst'[OF *] IH
    unfolding setopslsst_def case_prod_unfold subst_lsst_cons 
    by auto
qed (simp add: setopssst_def)

lemma setopslsstp_in_subst:
  assumes p: "p  setopslsstp (a lsstp δ)"
  shows "q  setopslsstp a. fst p = fst q  snd p = snd q p rm_vars (set (bvarssstp (snd a))) δ"
    (is "q  setopslsstp a. ?P q")
proof -
  obtain l b where a: "a = (l,b)" by (metis surj_pair)

  show ?thesis
  proof (cases b)
    case (NegChecks X F F')
    hence "p  (λ(t, s). (l, t  rm_vars (set X) δ, s  rm_vars (set X) δ)) ` set F'"
      using p a setopslsstp_subst_cases(7)[of l X F F' δ] by blast
    then obtain s t where st:
        "(t,s)  set F'" "p = (l, t  rm_vars (set X) δ, s  rm_vars (set X) δ)"
      by auto
    hence "(l,t,s)  setopslsstp a" "fst p = fst (l,t,s)"
          "snd p = snd (l,t,s) p rm_vars (set X) δ"
      using a NegChecks by fastforce+
    moreover have "bvarssstp (snd a) = X" using NegChecks a by auto
    ultimately show ?thesis by blast
  qed (use p a in auto)
qed

lemma setopslsst_in_subst:
  assumes "p  setopslsst (A lsst δ)"
  shows "q  setopslsst A. fst p = fst q  (X  bvarslsst A. snd p = snd q p rm_vars X δ)"
    (is "q  setopslsst A. ?P A q")
  using assms
proof (induction A)
  case (Cons a A)
  note 0 = unlabel_Cons(2)[of a A] bvarssst_Cons[of "snd a" "unlabel A"]
  show ?case
  proof (cases "p  setopslsst (A lsst δ)")
    case False
    hence "p  setopslsstp (a lsstp δ)"
      using Cons.prems setopslsst_cons[of "a lsstp δ" "A lsst δ"] subst_lsst_cons[of a A δ] by auto
    moreover have "(set (bvarssstp (snd a)))  bvarslsst (a#A)" using 0 by simp
    ultimately have "q  setopslsstp a. ?P (a#A) q" using setopslsstp_in_subst[of p a δ] by blast
    thus ?thesis by auto
  qed (use Cons.IH 0 in auto)
qed simp

lemma setopslsst_duallsst_eq:
  "setopslsst (duallsst A) = setopslsst A"
proof (induction A)
  case (Cons a A)
  obtain l b where "a = (l,b)" by (metis surj_pair)
  thus ?case using Cons unfolding setopslsst_def duallsst_def by (cases b) auto
qed simp

end

Theory Stateful_Compositionality

(*
(C) Copyright Andreas Viktor Hess, DTU, 2018-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Stateful_Compositionality.thy
    Author:     Andreas Viktor Hess, DTU
*)


section ‹Stateful Protocol Compositionality›
text ‹\label{Stateful-Compositionality}›

theory Stateful_Compositionality
imports Stateful_Typing Parallel_Compositionality Labeled_Stateful_Strands
begin

subsection ‹Small Lemmata›
lemma (in typed_model) wt_subst_sstp_vars_type_subset:
  fixes a::"('fun,'var) stateful_strand_step"
  assumes "wtsubst δ"
    and "t  subst_range δ. fv t = {}  (x. t = Var x)"
  shows "Γ ` Var ` fvsstp (a sstp δ)  Γ ` Var ` fvsstp a" (is ?A)
    and "Γ ` Var ` set (bvarssstp (a sstp δ)) = Γ ` Var ` set (bvarssstp a)" (is ?B)
    and "Γ ` Var ` varssstp (a sstp δ)  Γ ` Var ` varssstp a" (is ?C)
proof -
  show ?A
  proof
    fix τ assume τ: "τ  Γ ` Var ` fvsstp (a sstp δ)"
    then obtain x where x: "x  fvsstp (a sstp δ)" "Γ (Var x) = τ" by moura

    show "τ  Γ ` Var ` fvsstp a"
    proof (cases "x  fvsstp a")
      case False
      hence "y  fvsstp a. δ y = Var x"
      proof (cases a)
        case (NegChecks X F G)
        hence *: "x  fvpairs (F pairs rm_vars (set X) δ)  fvpairs (G pairs rm_vars (set X) δ)"
                 "x  set X"
          using fvsstp_NegCheck(1)[of X "F pairs rm_vars (set X) δ" "G pairs rm_vars (set X) δ"]
                fvsstp_NegCheck(1)[of X F G] False x(1)
          by fastforce+

        obtain y where y: "y  fvpairs F  fvpairs G" "x  fv (rm_vars (set X) δ y)"
          using fvpairs_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
                fvpairs_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
                *(1)
          by blast

        have "fv (rm_vars (set X) δ z) = {}  (u. rm_vars (set X) δ z = Var u)" for z
          using assms(2) rm_vars_img_subset[of "set X" δ] by blast
        hence "rm_vars (set X) δ y = Var x" using y(2) by fastforce
        hence "y  fvsstp a. rm_vars (set X) δ y = Var x"
          using y fvsstp_NegCheck(1)[of X F G] NegChecks *(2) by fastforce
        thus ?thesis by (metis (full_types) *(2) term.inject(1))
      qed (use assms(2) x(1) subst_apply_img_var'[of x _ δ] in fastforce)+
      then obtain y where y: "y  fvsstp a" "δ y = Var x" by moura
      hence "Γ (Var y) = τ" using x(2) assms(1) by (simp add: wtsubst_def)
      thus ?thesis using y(1) by auto
    qed (use x in auto)
  qed

  show ?B by (metis bvarssstp_subst)

  show ?C
  proof
    fix τ assume τ: "τ  Γ ` Var ` varssstp (a sstp δ)"
    then obtain x where x: "x  varssstp (a sstp δ)" "Γ (Var x) = τ" by moura

    show "τ  Γ ` Var ` varssstp a"
    proof (cases "x  varssstp a")
      case False
      hence "y  varssstp a. δ y = Var x"
      proof (cases a)
        case (NegChecks X F G)
        hence *: "x  fvpairs (F pairs rm_vars (set X) δ)  fvpairs (G pairs rm_vars (set X) δ)"
                 "x  set X"
          using varssstp_NegCheck[of X "F pairs rm_vars (set X) δ" "G pairs rm_vars (set X) δ"]
                varssstp_NegCheck[of X F G] False x(1)
          by (fastforce, blast)

        obtain y where y: "y  fvpairs F  fvpairs G" "x  fv (rm_vars (set X) δ y)"
          using fvpairs_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
                fvpairs_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
                *(1)
          by blast

        have "fv (rm_vars (set X) δ z) = {}  (u. rm_vars (set X) δ z = Var u)" for z
          using assms(2) rm_vars_img_subset[of "set X" δ] by blast
        hence "rm_vars (set X) δ y = Var x" using y(2) by fastforce
        hence "y  varssstp a. rm_vars (set X) δ y = Var x"
          using y varssstp_NegCheck[of X F G] NegChecks by blast
        thus ?thesis by (metis (full_types) *(2) term.inject(1))
      qed (use assms(2) x(1) subst_apply_img_var'[of x _ δ] in fastforce)+
      then obtain y where y: "y  varssstp a" "δ y = Var x" by moura
      hence "Γ (Var y) = τ" using x(2) assms(1) by (simp add: wtsubst_def)
      thus ?thesis using y(1) by auto
    qed (use x in auto)
  qed
qed

lemma (in typed_model) wt_subst_lsst_vars_type_subset:
  fixes A::"('fun,'var,'a) labeled_stateful_strand"
  assumes "wtsubst δ"
    and "t  subst_range δ. fv t = {}  (x. t = Var x)"
  shows "Γ ` Var ` fvlsst (A lsst δ)  Γ ` Var ` fvlsst A" (is ?A)
    and "Γ ` Var ` bvarslsst (A lsst δ) = Γ ` Var ` bvarslsst A" (is ?B)
    and "Γ ` Var ` varslsst (A lsst δ)  Γ ` Var ` varslsst A" (is ?C)
proof -
  have "varslsst (a#A lsst δ) = varssstp (b sstp δ)  varslsst (A lsst δ)"
       "varslsst (a#A) = varssstp b  varslsst A"
       "fvlsst (a#A lsst δ) = fvsstp (b sstp δ)  fvlsst (A lsst δ)"
       "fvlsst (a#A) = fvsstp b  fvlsst A"
       "bvarslsst (a#A lsst δ) = set (bvarssstp (b sstp δ))  bvarslsst (A lsst δ)"
       "bvarslsst (a#A) = set (bvarssstp b)  bvarslsst A"
    when "a = (l,b)" for a l b and A::"('fun,'var,'a) labeled_stateful_strand"
    using that unlabel_Cons(1)[of l b A] unlabel_subst[of "a#A" δ]
          subst_lsst_cons[of a A δ] subst_sst_cons[of b "unlabel A" δ]
          subst_apply_labeled_stateful_strand_step.simps(1)[of l b δ]
          varssst_unlabel_Cons[of l b A] varssst_unlabel_Cons[of l "b sstp δ" "A lsst δ"]
          fvsst_unlabel_Cons[of l b A] fvsst_unlabel_Cons[of l "b sstp δ" "A lsst δ"]
          bvarssst_unlabel_Cons[of l b A] bvarssst_unlabel_Cons[of l "b sstp δ" "A lsst δ"]
    by simp_all
  hence *: "Γ ` Var ` varslsst (a#A lsst δ) =
            Γ ` Var ` varssstp (b sstp δ)  Γ ` Var ` varslsst (A lsst δ)"
           "Γ ` Var ` varslsst (a#A) = Γ ` Var ` varssstp b  Γ ` Var ` varslsst A"
           "Γ ` Var ` fvlsst (a#A lsst δ) =
            Γ ` Var ` fvsstp (b sstp δ)  Γ ` Var ` fvlsst (A lsst δ)"
           "Γ ` Var ` fvlsst (a#A) = Γ ` Var ` fvsstp b  Γ ` Var ` fvlsst A"
           "Γ ` Var ` bvarslsst (a#A lsst δ) =
            Γ ` Var ` set (bvarssstp (b sstp δ))  Γ ` Var ` bvarslsst (A lsst δ)"
           "Γ ` Var ` bvarslsst (a#A) = Γ ` Var ` set (bvarssstp b)  Γ ` Var ` bvarslsst A"
    when "a = (l,b)" for a l b and A::"('fun,'var,'a) labeled_stateful_strand"
    using that by fast+

  have "?A  ?B  ?C"
  proof (induction A)
    case (Cons a A)
    obtain l b where a: "a = (l,b)" by (metis surj_pair)

    show ?case
      using Cons.IH wt_subst_sstp_vars_type_subset[OF assms, of b] *[OF a, of A]
      by (metis Un_mono)
  qed simp
  thus ?A ?B ?C by metis+
qed

lemma (in stateful_typed_model) fv_pair_fvpairs_subset:
  assumes "d  set D"
  shows "fv (pair (snd d))  fvpairs (unlabel D)"
using assms unfolding pair_def by (induct D) (auto simp add: unlabel_def)

lemma (in stateful_typed_model) labeled_sat_ineq_lift:
  assumes "M; map (λd. X⟨∨≠: [(pair (t,s), pair (snd d))]st) [ddbproj i D. d  set Di]d "
    (is "?R1 D")
  and "(j,p)  {(i,t,s)}  set D  set Di. (k,q)  {(i,t,s)}  set D  set Di.
          (δ. Unifier δ (pair p) (pair q))  j = k" (is "?R2 D")
  shows "M; map (λd. X⟨∨≠: [(pair (t,s), pair (snd d))]st) [dD. d  set Di]d "
using assms
proof (induction D)
  case (Cons dl D)
  obtain d l where dl: "dl = (l,d)" by (metis surj_pair)

  have 1: "?R1 D"
  proof (cases "i = l")
    case True thus ?thesis using Cons.prems(1) dl by (cases "dl  set Di") auto
  next
    case False thus ?thesis using Cons.prems(1) dl by auto
  qed

  have "set D  set (dl#D)" by auto
  hence 2: "?R2 D" using Cons.prems(2) by blast

  have "i  l  dl  set Di  M; [X⟨∨≠: [(pair (t,s), pair (snd dl))]st]d "
    using Cons.prems(1) dl by (auto simp add: ineq_model_def)
  moreover have "δ. Unifier δ (pair (t,s)) (pair d)  i = l"
    using Cons.prems(2) dl by force
  ultimately have 3: "dl  set Di  M; [X⟨∨≠: [(pair (t,s), pair (snd dl))]st]d "
    using strand_sem_not_unif_is_sat_ineq[of "pair (t,s)" "pair d"] dl by fastforce

  show ?case using Cons.IH[OF 1 2] 3 dl by auto
qed simp

lemma (in stateful_typed_model) labeled_sat_ineq_dbproj:
  assumes "M; map (λd. X⟨∨≠: [(pair (t,s), pair (snd d))]st) [dD. d  set Di]d "
    (is "?P D")
  shows "M; map (λd. X⟨∨≠: [(pair (t,s), pair (snd d))]st) [ddbproj i D. d  set Di]d "
    (is "?Q D")
using assms
proof (induction D)
  case (Cons di D)
  obtain d j where di: "di = (j,d)" by (metis surj_pair)

  have "?P D" using Cons.prems by (cases "di  set Di") auto
  hence IH: "?Q D" by (metis Cons.IH)

  show ?case using di IH
  proof (cases "i = j  di  set Di")
    case True
    have 1: "M; [X⟨∨≠: [(pair (t,s), pair (snd di))]st]d "
      using Cons.prems True by auto
    have 2: "dbproj i (di#D) = di#dbproj i D" using True dbproj_Cons(1) di by auto
    show ?thesis using 1 2 IH by auto
  qed auto
qed simp

lemma (in stateful_typed_model) labeled_sat_ineq_dbproj_sem_equiv:
  assumes "(j,p)  ((λ(t, s). (i, t, s)) ` set F')  set D.
           (k,q)  ((λ(t, s). (i, t, s)) ` set F')  set D.
            (δ. Unifier δ (pair p) (pair q))  j = k"
  and "fvpairs (map snd D)  set X = {}"
  shows "M; map (λG. X⟨∨≠: (F@G)st) (trpairs F' (map snd D))d  
         M; map (λG. X⟨∨≠: (F@G)st) (trpairs F' (map snd (dbproj i D)))d "
proof -
  let ?A = "set (map snd D) pset "
  let ?B = "set (map snd (dbproj i D)) pset "
  let ?C = "set (map snd D) - set (map snd (dbproj i D))"
  let ?F = "(λ(t, s). (i, t, s)) ` set F'"
  let ?P = "λδ. subst_domain δ = set X  ground (subst_range δ)"

  have 1: "(t, t')  set (map snd D). (fv t  fv t')  set X = {}"
          "(t, t')  set (map snd (dbproj i D)). (fv t  fv t')  set X = {}"
    using assms(2) dbproj_subset[of i D] unfolding unlabel_def by force+

  have 2: "?B  ?A" by auto

  have 3: "¬Unifier δ (pair f) (pair d)"
    when f: "f  set F'" and d: "d  set (map snd D) - set (map snd (dbproj i D))"
    for f d and δ::"('fun,'var) subst"
  proof -
    obtain k where k: "(k,d)  set D - set (dbproj i D)"
      using d by force

    have "(i,f)  ((λ(t, s). (i, t, s)) ` set F')  set D"
         "(k,d)  ((λ(t, s). (i, t, s)) ` set F')  set D"
      using f k by auto
    hence "i = k" when "Unifier δ (pair f) (pair d)" for δ
      using assms(1) that by blast
    moreover have "k  i" using k d by simp
    ultimately show ?thesis by metis
  qed

  have "f p δ  d p δ"
    when "f  set F'" "d  ?C" for f d and δ::"('fun,'var) subst"
    by (metis fun_pair_eq_subst 3[OF that])
  hence "f p (δ s )  ?C pset (δ s )"
    when "f  set F'" for f and δ::"('fun,'var) subst"
    using that by blast
  moreover have "?C pset δ pset  = ?C pset "
    when "?P δ" for δ
    using assms(2) that pairs_substI[of δ "(set (map snd D) - set (map snd (dbproj i D)))"]
    by blast
  ultimately have 4: "f p (δ s )  ?C pset "
    when "f  set F'" "?P δ" for f and δ::"('fun,'var) subst"
    by (metis that subst_pairs_compose)

  { fix f and δ::"('fun,'var) subst"
    assume "f  set F'" "?P δ"
    hence "f p (δ s )  ?C pset " by (metis 4)
    hence "f p (δ s )  ?A - ?B" by force
  } hence 5: "fset F'. δ. ?P δ  f p (δ s )  ?A - ?B" by metis

  show ?thesis
    using negchecks_model_db_subset[OF 2]
          negchecks_model_db_supset[OF 2 5]
          trpairs_sem_equiv[OF 1(1)]
          trpairs_sem_equiv[OF 1(2)]
          tr_NegChecks_constr_iff(1)
          strand_sem_eq_defs(2)
    by (metis (no_types, lifting))
qed

lemma (in stateful_typed_model) labeled_sat_eqs_list_all:
  assumes "(j, p)  {(i,t,s)}  set D. (k,q)  {(i,t,s)}  set D.
              (δ. Unifier δ (pair p) (pair q))  j = k" (is "?P D")
  and "M; map (λd. ac: (pair (t,s))  (pair (snd d))st) Dd " (is "?Q D")
  shows "list_all (λd. fst d = i) D"
using assms
proof (induction D rule: List.rev_induct)
  case (snoc di D)
  obtain d j where di: "di = (j,d)" by (metis surj_pair)
  have "pair (t,s)   = pair d  " using di snoc.prems(2) by auto
  hence "δ. Unifier δ (pair (t,s)) (pair d)" by auto
  hence 1: "i = j" using snoc.prems(1) di by fastforce

  have "set D  set (D@[di])" by auto
  hence 2: "?P D" using snoc.prems(1) by blast

  have 3: "?Q D" using snoc.prems(2) by auto

  show ?case using di 1 snoc.IH[OF 2 3] by simp
qed simp

lemma (in stateful_typed_model) labeled_sat_eqs_subseqs:
  assumes "Di  set (subseqs D)"
  and "(j, p)  {(i,t,s)}  set D. (k, q)  {(i,t,s)}  set D.
          (δ. Unifier δ (pair p) (pair q))  j = k" (is "?P D")
  and "M; map (λd. ac: (pair (t,s))  (pair (snd d))st) Did "
  shows "Di  set (subseqs (dbproj i D))"
proof -
  have "set Di  set D" by (rule subseqs_subset[OF assms(1)])
  hence "?P Di" using assms(2) by blast
  thus ?thesis using labeled_sat_eqs_list_all[OF _ assms(3)] subseqs_mem_dbproj[OF assms(1)] by simp
qed

lemma (in stateful_typed_model) duallsst_tfrsstp:
  assumes "list_all tfrsstp (unlabel S)"
  shows "list_all tfrsstp (unlabel (duallsst S))"
using assms
proof (induction S)
  case (Cons a S)
  have prems: "tfrsstp (snd a)" "list_all tfrsstp (unlabel S)"
    using Cons.prems unlabel_Cons(2)[of a S] by simp_all
  hence IH: "list_all tfrsstp (unlabel (duallsst S))" by (metis Cons.IH)

  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  with Cons show ?case
  proof (cases b)
    case (Equality c t t')
    hence "duallsst (a#S) = a#duallsst S" by (metis duallsst_Cons(3) a)
    thus ?thesis using a IH prems by fastforce
  next
    case (NegChecks X F G)
    hence "duallsst (a#S) = a#duallsst S" by (metis duallsst_Cons(7) a)
    thus ?thesis using a IH prems by fastforce
  qed auto
qed simp

lemma (in stateful_typed_model) setopssst_unlabel_duallsst_eq:
  "setopssst (unlabel (duallsst A)) = setopssst (unlabel A)"
proof (induction A)
  case (Cons a A)
  obtain l b where a: "a = (l,b)" by (metis surj_pair)
  thus ?case using Cons.IH by (cases b) (simp_all add: setopssst_def)
qed simp


subsection ‹Locale Setup and Definitions›
locale labeled_stateful_typed_model =
  stateful_typed_model arity public Ana Γ Pair
+ labeled_typed_model arity public Ana Γ label_witness1 label_witness2
  for arity::"'fun  nat"
  and public::"'fun  bool"
  and Ana::"('fun,'var) term  (('fun,'var) term list × ('fun,'var) term list)"
  and Γ::"('fun,'var) term  ('fun,'atom::finite) term_type"
  and Pair::"'fun"
  and label_witness1::"'lbl"
  and label_witness2::"'lbl"
begin

definition lpair where
  "lpair lp  case lp of (i,p)  (i,pair p)"

lemma setopslsstp_pair_image[simp]:
  "lpair ` (setopslsstp (i,send⟨t)) = {}"
  "lpair ` (setopslsstp (i,receive⟨t)) = {}"
  "lpair ` (setopslsstp (i,ac: t  t')) = {}"
  "lpair ` (setopslsstp (i,insert⟨t,s)) = {(i, pair (t,s))}"
  "lpair ` (setopslsstp (i,delete⟨t,s)) = {(i, pair (t,s))}"
  "lpair ` (setopslsstp (i,ac: t  s)) = {(i, pair (t,s))}"
  "lpair ` (setopslsstp (i,X⟨∨≠: F ∨∉: F')) = ((λ(t,s). (i, pair (t,s))) ` set F')"
unfolding lpair_def by force+

definition par_complsst where
  "par_complsst (𝒜::('fun,'var,'lbl) labeled_stateful_strand) (Secrets::('fun,'var) terms) 
    (l1 l2. l1  l2 
              GSMP_disjoint (trmssst (proj_unl l1 𝒜)  pair ` setopssst (proj_unl l1 𝒜))
                            (trmssst (proj_unl l2 𝒜)  pair ` setopssst (proj_unl l2 𝒜)) Secrets) 
    ground Secrets  (s  Secrets. s'  subterms s. {} c s'  s'  Secrets) 
    ((i,p)  setopslsst 𝒜. (j,q)  setopslsst 𝒜.
      (δ. Unifier δ (pair p) (pair q))  i = j)"

definition declassifiedlsst where
  "declassifiedlsst 𝒜   {t. ⟨⋆, receive⟨t  set 𝒜} set "

definition strand_leakslsst ("_ leaks _ under _") where
  "(𝒜::('fun,'var,'lbl) labeled_stateful_strand) leaks Secrets under  
    (t  Secrets - declassifiedlsst 𝒜 . n.  s (proj_unl n 𝒜@[send⟨t]))"

definition typing_condsst where
  "typing_condsst 𝒜  wfsst 𝒜  wftrms (trmssst 𝒜)  tfrsst 𝒜"

type_synonym ('a,'b,'c) labeleddbstate = "('c strand_label × (('a,'b) term × ('a,'b) term)) set"
type_synonym ('a,'b,'c) labeleddbstatelist = "('c strand_label × (('a,'b) term × ('a,'b) term)) list"

text ‹
  For proving the compositionality theorem for stateful constraints the idea is to first define a
  variant of the reduction technique that was used to establish the stateful typing result. This
  variant performs database-state projections, and it allows us to reduce the compositionality
  problem for stateful constraints to ordinary constraints.
›
fun trpc::
  "('fun,'var,'lbl) labeled_stateful_strand  ('fun,'var,'lbl) labeleddbstatelist
    ('fun,'var,'lbl) labeled_strand list"
where
  "trpc [] D = [[]]"
| "trpc ((i,send⟨t)#A) D = map ((#) (i,send⟨tst)) (trpc A D)"
| "trpc ((i,receive⟨t)#A) D = map ((#) (i,receive⟨tst)) (trpc A D)"
| "trpc ((i,ac: t  t')#A) D = map ((#) (i,ac: t  t'st)) (trpc A D)"
| "trpc ((i,insert⟨t,s)#A) D = trpc A (List.insert (i,(t,s)) D)"
| "trpc ((i,delete⟨t,s)#A) D = (
    concat (map (λDi. map (λB. (map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di)@
                               (map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st))
                                    [ddbproj i D. d  set Di])@B)
                          (trpc A [dD. d  set Di]))
                (subseqs (dbproj i D))))"
| "trpc ((i,ac: t  s)#A) D =
    concat (map (λB. map (λd. (i,ac: (pair (t,s))  (pair (snd d))st)#B) (dbproj i D)) (trpc A D))"
| "trpc ((i,X⟨∨≠: F ∨∉: F' )#A) D =
    map ((@) (map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd (dbproj i D))))) (trpc A D)"


subsection ‹Small Lemmata›
lemma par_complsst_nil:
  assumes "ground Sec" "s  Sec. s'subterms s. {} c s'  s'  Sec"
  shows "par_complsst [] Sec"
using assms unfolding par_complsst_def by simp

lemma par_complsst_subset:
  assumes A: "par_complsst A Sec"
    and BA: "set B  set A"
  shows "par_complsst B Sec"
proof -
  let ?L = "λn A. trmssst (proj_unl n A)  pair ` setopssst (proj_unl n A)"

  have "?L n B  ?L n A" for n
    using trmssst_mono[OF proj_set_mono(2)[OF BA]] setopssst_mono[OF proj_set_mono(2)[OF BA]]
    by blast
  hence "GSMP_disjoint (?L m B) (?L n B) Sec" when nm: "m  n" for n m::'lbl
    using GSMP_disjoint_subset[of "?L m A" "?L n A" Sec "?L m B" "?L n B"] A nm
    unfolding par_complsst_def by simp
  thus "par_complsst B Sec"
    using A setopslsst_mono[OF BA]
    unfolding par_complsst_def by blast
qed

lemma par_complsst_split:
  assumes "par_complsst (A@B) Sec"
  shows "par_complsst A Sec" "par_complsst B Sec"
using par_complsst_subset[OF assms] by simp_all

lemma par_complsst_proj:
  assumes "par_complsst A Sec"
  shows "par_complsst (proj n A) Sec"
using par_complsst_subset[OF assms] by simp

lemma par_complsst_duallsst:
  assumes A: "par_complsst A S"
  shows "par_complsst (duallsst A) S"
proof (unfold par_complsst_def case_prod_unfold; intro conjI)
  show "ground S" "s  S. s'  subterms s. {} c s'  s'  S"
    using A unfolding par_complsst_def by fast+

  let ?M = "λl B. (trmslsst (proj l B)  pair ` setopssst (proj_unl l B))"
  let ?P = "λB. l1 l2. l1  l2  GSMP_disjoint (?M l1 B) (?M l2 B) S"
  let ?Q = "λB. p  setopslsst B. q  setopslsst B.
    (δ. Unifier δ (pair (snd p)) (pair (snd q)))  fst p = fst q"

  have "?P A" "?Q A" using A unfolding par_complsst_def case_prod_unfold by blast+
  thus "?P (duallsst A)" "?Q (duallsst A)"
    by (metis setopssst_unlabel_duallsst_eq trmssst_unlabel_duallsst_eq proj_duallsst,
        metis setopslsst_duallsst_eq)
qed

lemma par_complsst_subst:
  assumes A: "par_complsst A S"
    and δ: "wtsubst δ" "wftrms (subst_range δ)" "subst_domain δ  bvarslsst A = {}"
  shows "par_complsst (A lsst δ) S"
proof (unfold par_complsst_def case_prod_unfold; intro conjI)
  show "ground S" "s  S. s'  subterms s. {} c s'  s'  S"
    using A unfolding par_complsst_def by fast+

  let ?N = "λl B. trmslsst (proj l B)  pair ` setopssst (proj_unl l B)"
  define M where "M  λl (B::('fun,'var,'lbl) labeled_stateful_strand). ?N l B"
  let ?P = "λp q. δ. Unifier δ (pair (snd p)) (pair (snd q))"
  let ?Q = "λB. p  setopslsst B. q  setopslsst B. ?P p q  fst p = fst q"
  let ?R = "λB. l1 l2. l1  l2  GSMP_disjoint (?N l1 B) (?N l2 B) S"

  have d: "bvarslsst (proj l A)  subst_domain δ = {}" for l
    using δ(3) unfolding proj_def bvarssst_def unlabel_def by auto

  have "GSMP_disjoint (M l1 A) (M l2 A) S" when l: "l1  l2" for l1 l2
    using l A unfolding par_complsst_def M_def by presburger
  moreover have "M l (A lsst δ) = (M l A) set δ" for l
    using fun_pair_subst_set[of δ "setopssst (proj_unl l A)", symmetric]
          trmssst_subst[OF d[of l]] setopssst_subst[OF d[of l]] proj_subst[of l A δ]
    unfolding M_def unlabel_subst by auto
  ultimately have "GSMP_disjoint (M l1 (A lsst δ)) (M l2 (A lsst δ)) S" when l: "l1  l2" for l1 l2
    using l GSMP_wt_subst_subset[OF _ δ(1,2), of _ "M l1 A"]
          GSMP_wt_subst_subset[OF _ δ(1,2), of _ "M l2 A"]
    unfolding GSMP_disjoint_def by fastforce
  thus "?R (A lsst δ)" unfolding M_def by blast

  have "?Q A" using A unfolding par_complsst_def by force
  thus "?Q (A lsst δ)" using δ(3)
  proof (induction A)
    case (Cons a A)
    obtain l b where a: "a = (l,b)" by (metis surj_pair)

    have 0: "bvarslsst (a#A) = set (bvarssstp (snd a))  bvarslsst A"
      unfolding bvarssst_def unlabel_def by simp

    have "?Q A" "subst_domain δ  bvarslsst A = {}"
      using Cons.prems 0 unfolding setopslsst_def by auto
    hence IH: "?Q (A lsst δ)" using Cons.IH unfolding setopslsst_def by blast

    have 1: "fst p = fst q"
      when p: "p  setopslsstp (a lsstp δ)"
        and q: "q  setopslsstp (a lsstp δ)"
        and pq: "?P p q"
      for p q
      using a p q pq by (cases b) auto

    have 2: "fst p = fst q"
      when p: "p  setopslsst (A lsst δ)"
        and q: "q  setopslsstp (a lsstp δ)"
        and pq: "?P p q"
      for p q
    proof -
      obtain p' X where p':
          "p'  setopslsst A" "fst p = fst p'"
          "X  bvarslsst (a#A)" "snd p = snd p' p rm_vars X δ"
        using setopslsst_in_subst[OF p] 0 by blast

      obtain q' Y where q':
          "q'  setopslsstp a" "fst q = fst q'"
          "Y  bvarslsst (a#A)" "snd q = snd q' p rm_vars Y δ"
        using setopslsstp_in_subst[OF q] 0 by blast

      have "pair (snd p) = pair (snd p')  δ"
           "pair (snd q) = pair (snd q')  δ"
        using fun_pair_subst[of "snd p'" "rm_vars X δ"] fun_pair_subst[of "snd q'" "rm_vars Y δ"]
              p'(3,4) q'(3,4) Cons.prems(2) rm_vars_apply'[of δ X] rm_vars_apply'[of δ Y]
        by fastforce+
      hence "δ. Unifier δ (pair (snd p')) (pair (snd q'))"
        using pq Unifier_comp' by metis
      thus ?thesis using Cons.prems p'(1,2) q'(1,2) by simp
    qed

    show ?case by (metis 1 2 IH Un_iff setopslsst_cons subst_lsst_cons)
  qed simp
qed

lemma wf_pair_negchecks_map':
  assumes "wfst X (unlabel A)"
  shows "wfst X (unlabel (map (λG. (i,Y⟨∨≠: (F@G)st)) M@A))"
using assms by (induct M) auto

lemma wf_pair_eqs_ineqs_map':
  fixes A::"('fun,'var,'lbl) labeled_strand"
  assumes "wfst X (unlabel A)"
          "Di  set (subseqs (dbproj i D))"
          "fvpairs (unlabel D)  X"
  shows "wfst X (unlabel (
            (map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di)@
            (map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) [ddbproj i D. d  set Di])@A))"
proof -
  let ?f = "[ddbproj i D. d  set Di]"
  define c1 where c1: "c1 = map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di"
  define c2 where c2: "c2 = map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) ?f"
  define c3 where c3: "c3 = map (λd. check: (pair (t,s))  (pair d)st) (unlabel Di)"
  define c4 where c4: "c4 = map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) (unlabel ?f)"
  have ci_eqs: "c3 = unlabel c1" "c4 = unlabel c2" unfolding c1 c2 c3 c4 unlabel_def by auto
  have 1: "wfst X (unlabel (c2@A))"
    using wf_fun_pair_ineqs_map[OF assms(1)] ci_eqs(2) unlabel_append[of c2 A] c4
    by metis
  have 2: "fvpairs (unlabel Di)  X"
    using assms(3) subseqs_set_subset(1)[OF assms(2)]
    unfolding unlabel_def
    by fastforce
  { fix B::"('fun,'var) strand" assume "wfst X B"
    hence "wfst X (unlabel c1@B)" using 2 unfolding c1 unlabel_def by (induct Di) auto
  } thus ?thesis using 1 unfolding c1 c2 unlabel_def by simp
qed

lemma trmssst_setopssst_wt_instance_ex:
  defines "M  λA. trmslsst A  pair ` setopssst (unlabel A)"
  assumes B: "b  set B. a  set A. δ. b = a lsstp δ  wtsubst δ  wftrms (subst_range δ)"
  shows "t  M B. s  M A. δ. t = s  δ  wtsubst δ  wftrms (subst_range δ)"
proof
  let ?P = "λδ. wtsubst δ  wftrms (subst_range δ)"

  fix t assume "t  M B"
  then obtain b where b: "b  set B" "t  trmssstp (snd b)  pair ` setopssstp (snd b)"
    unfolding M_def unfolding unlabel_def trmssst_def setopssst_def by auto
  then obtain a δ where a: "a  set A" "b = a lsstp δ" and δ: "wtsubst δ" "wftrms (subst_range δ)"
    using B by meson

  note δ' = wt_subst_rm_vars[OF δ(1)] wf_trms_subst_rm_vars'[OF δ(2)]

  have "t  M (A lsst δ)"
    using b(2) a
    unfolding M_def subst_apply_labeled_stateful_strand_def unlabel_def trmssst_def setopssst_def
    by auto
  moreover have "s  M A. δ. t = s  δ  ?P δ" when "t  trmslsst (A lsst δ)"
    using trmssst_unlabel_subst'[OF that] δ' unfolding M_def by blast
  moreover have "s  M A. δ. t = s  δ  ?P δ" when t: "t  pair ` setopssst (unlabel A sst δ)"
  proof -
    obtain p where p: "p  setopssst (unlabel A sst δ)" "t = pair p" using t by blast
    then obtain q X where q: "q  setopssst (unlabel A)" "p = q p rm_vars (set X) δ"
      using setopssst_subst'[OF p(1)] by blast
    hence "t = pair q  rm_vars (set X) δ"
      using fun_pair_subst[of q "rm_vars (set X) δ"] p(2) by presburger
    thus ?thesis using δ'[of "set X"] q(1) unfolding M_def by blast
  qed
  ultimately show "s  M A. δ. t = s  δ  ?P δ" unfolding M_def unlabel_subst by fast
qed

lemma setopslsst_wt_instance_ex:
  assumes B: "b  set B. a  set A. δ. b = a lsstp δ  wtsubst δ  wftrms (subst_range δ)"
  shows "p  setopslsst B. q  setopslsst A. δ.
    fst p = fst q  snd p = snd q p δ  wtsubst δ  wftrms (subst_range δ)"
proof
  let ?P = "λδ. wtsubst δ  wftrms (subst_range δ)"

  fix p assume "p  setopslsst B"
  then obtain b where b: "b  set B" "p  setopslsstp b" unfolding setopslsst_def by blast
  then obtain a δ where a: "a  set A" "b = a lsstp δ" and δ: "wtsubst δ" "wftrms (subst_range δ)"
    using B by meson
  hence p: "p  setopslsst (A lsst δ)"
    using b(2) unfolding setopslsst_def subst_apply_labeled_stateful_strand_def by auto

  obtain X q where q:
      "q  setopslsst A" "fst p = fst q" "snd p = snd q p rm_vars X δ"
    using setopslsst_in_subst[OF p] by blast

  show "q  setopslsst A. δ. fst p = fst q  snd p = snd q p δ  ?P δ"
    using q wt_subst_rm_vars[OF δ(1)] wf_trms_subst_rm_vars'[OF δ(2)] by blast
qed


subsection ‹Lemmata: Properties of the Constraint Translation Function›
lemma tr_par_labeled_rcv_iff:
  "B  set (trpc A D)  (i, receive⟨tst)  set B  (i, receive⟨t)  set A"
by (induct A D arbitrary: B rule: trpc.induct) auto

lemma tr_par_declassified_eq:
  "B  set (trpc A D)  declassifiedlst B I = declassifiedlsst A I"
using tr_par_labeled_rcv_iff unfolding declassifiedlst_def declassifiedlsst_def by simp

lemma tr_par_ik_eq:
  assumes "B  set (trpc A D)"
  shows "ikst (unlabel B) = iksst (unlabel A)"
proof -
  have "{t. i. (i, receive⟨tst)  set B} = {t. i. (i, receive⟨t)  set A}"
    using tr_par_labeled_rcv_iff[OF assms] by simp
  moreover have
      "C. {t. i. (i, receive⟨tst)  set C} = {t. receive⟨tst  set (unlabel C)}"
      "C. {t. i. (i, receive⟨t)  set C} = {t. receive⟨t  set (unlabel C)}"
    unfolding unlabel_def by force+
  ultimately show ?thesis by (metis iksst_def ikst_is_rcv_set)
qed

lemma tr_par_deduct_iff:
  assumes "B  set (trpc A D)"
  shows "ikst (unlabel B) set I  t  iksst (unlabel A) set I  t"
using tr_par_ik_eq[OF assms] by metis

lemma tr_par_vars_subset:
  assumes "A'  set (trpc A D)"
  shows "fvlst A'  fvsst (unlabel A)  fvpairs (unlabel D)" (is ?P)
  and "bvarslst A'  bvarssst (unlabel A)" (is ?Q)
proof -
  show ?P using assms
  proof (induction "unlabel A" arbitrary: A A' D rule: strand_sem_stateful_induct)
    case (ConsIn A' D ac t s AA A A')
    then obtain i B where iB: "A = (i,ac: t  s)#B" "AA = unlabel B"
      unfolding unlabel_def by moura
    then obtain A'' d where *:
        "d  set (dbproj i D)"
        "A' = (i,ac: (pair (t,s))  (pair (snd d))st)#A''"
        "A''  set (trpc B D)"
      using ConsIn.prems(1) by moura
    hence "fvlst A''  fvsst (unlabel B)  fvpairs (unlabel D)"
          "fv (pair (snd d))  fvpairs (unlabel D)"
      apply (metis ConsIn.hyps(1)[OF iB(2)])
      using fvpairs_mono[OF dbproj_subset[of i D]]
            fv_pair_fvpairs_subset[OF *(1)]
      by blast
    thus ?case using * iB unfolding pair_def by auto
  next
    case (ConsDel A' D t s AA A A')
    then obtain i B where iB: "A = (i,delete⟨t,s)#B" "AA = unlabel B"
      unfolding unlabel_def by moura

    define fltD1 where "fltD1 = (λDi. filter (λd. d  set Di) D)"
    define fltD2 where "fltD2 = (λDi. filter (λd. d  set Di) (dbproj i D))"
    define constr where "constr =
      (λDi. (map (λd. (i, check: (pair (t,s))  (pair (snd d))st)) Di)@
            (map (λd. (i, []⟨∨≠: [(pair (t,s), pair (snd d))]st)) (fltD2 Di)))"

    from iB obtain A'' Di where *:
        "Di  set (subseqs (dbproj i D))" "A' = (constr Di)@A''" "A''  set (trpc B (fltD1 Di))"
      using ConsDel.prems(1) unfolding constr_def fltD1_def fltD2_def by moura
    hence "fvlst A''  fvsst AA  fvpairs (unlabel (fltD1 Di))"
      unfolding constr_def fltD1_def by (metis ConsDel.hyps(1) iB(2))
    hence 1: "fvlst A''  fvsst AA  fvpairs (unlabel D)"
      using fvpairs_mono[of "unlabel (fltD1 Di)" "unlabel D"]
      unfolding unlabel_def fltD1_def by force

    have 2: "fvpairs (unlabel Di)  fvpairs (unlabel (fltD1 Di))  fvpairs (unlabel D)"
      using subseqs_set_subset(1)[OF *(1)]
      unfolding fltD1_def unlabel_def
      by auto

    have 5: "fvlst A' = fvlst (constr Di)  fvlst A''" using * unfolding unlabel_def by force

    have "fvlst (constr Di)  fv t  fv s  fvpairs (unlabel Di)  fvpairs (unlabel (fltD1 Di))"
      unfolding unlabel_def constr_def fltD1_def fltD2_def pair_def by auto
    hence 3: "fvlst (constr Di)  fv t  fv s  fvpairs (unlabel D)" using 2 by blast

    have 4: "fvsst (unlabel A) = fv t  fv s  fvsst AA" using iB by auto

    have "fvst (unlabel A')  fvsst (unlabel A)  fvpairs (unlabel D)" using 1 3 4 5 by blast
    thus ?case by metis
  next
    case (ConsNegChecks A' D X F F' AA A A')
    then obtain i B where iB: "A = (i,NegChecks X F F')#B" "AA = unlabel B"
      unfolding unlabel_def by moura

    define D' where "D'  (fvpairs ` set (trpairs F' (unlabel (dbproj i D))))"
    define constr where "constr = map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd (dbproj i D)))"

    from iB obtain A'' where *: "A''  set (trpc B D)" "A' = constr@A''"
      using ConsNegChecks.prems(1) unfolding constr_def by moura
    hence "fvlst A''  fvsst AA  fvpairs (unlabel D)"
      by (metis ConsNegChecks.hyps(1) iB(2))
    hence **: "fvlst A''  fvsst AA  fvpairs (unlabel D)" by auto

    have 1: "fvlst constr  (D'  fvpairs F) - set X"
      unfolding D'_def constr_def unlabel_def by auto

    have "set (unlabel (dbproj i D))  set (unlabel D)" unfolding unlabel_def by auto
    hence 2: "D'  fvpairs F'  fvpairs (unlabel D)"
      using trpairs_vars_subset'[of F' "unlabel (dbproj i D)"] fvpairs_mono
      unfolding D'_def by blast

    have 3: "fvlst A'  ((fvpairs F'  fvpairs F) - set X)  fvpairs (unlabel D)  fvlst A''"
      using 1 2 *(2) unfolding unlabel_def by fastforce

    have 4: "fvsst AA  fvsst (unlabel A)" by (metis ConsNegChecks.hyps(2) fvsst_cons_subset)

    have 5: "fvpairs F'  fvpairs F - set X  fvsst (unlabel A)"
      using ConsNegChecks.hyps(2) unfolding unlabel_def by force

    show ?case using ** 3 4 5 by blast
  qed (fastforce simp add: unlabel_def)+

  show ?Q using assms
    apply (induct "unlabel A" arbitrary: A A' D rule: strand_sem_stateful_induct)
    by (fastforce simp add: unlabel_def)+
qed

lemma tr_par_vars_disj:
  assumes "A'  set (trpc A D)" "fvpairs (unlabel D)  bvarssst (unlabel A) = {}"
  and "fvsst (unlabel A)  bvarssst (unlabel A) = {}"
  shows "fvlst A'  bvarslst A' = {}"
using assms tr_par_vars_subset by fast

lemma tr_par_trms_subset:
  assumes "A'  set (trpc A D)"
  shows "trmslst A'  trmssst (unlabel A)  pair ` setopssst (unlabel A)  pair ` snd ` set D"
using assms
proof (induction A D arbitrary: A' rule: trpc.induct)
  case 1 thus ?case by simp
next
  case (2 i t A D)
  then obtain A'' where A'': "A' = (i,send⟨tst)#A''" "A''  set (trpc A D)" by moura
  hence "trmslst A''  trmssst (unlabel A)  pair ` setopssst (unlabel A)  pair ` snd ` set D"
    by (metis "2.IH")
  thus ?case using A'' by (auto simp add: setopssst_def)
next
  case (3 i t A D)
  then obtain A'' where A'': "A' = (i,receive⟨tst)#A''" "A''  set (trpc A D)"
    by moura
  hence "trmslst A''  trmssst (unlabel A)  pair ` setopssst (unlabel A)  pair ` snd ` set D"
    by (metis "3.IH")
  thus ?case using A'' by (auto simp add: setopssst_def)
next
  case (4 i ac t t' A D)
  then obtain A'' where A'': "A' = (i,ac: t  t'st)#A''" "A''  set (trpc A D)"
    by moura
  hence "trmslst A''  trmssst (unlabel A)  pair ` setopssst (unlabel A)  pair ` snd ` set D"
    by (metis "4.IH")
  thus ?case using A'' by (auto simp add: setopssst_def)
next
  case (5 i t s A D)
  hence "A'  set (trpc A (List.insert (i,t,s) D))" by simp
  hence "trmslst A'  trmssst (unlabel A)  pair ` setopssst (unlabel A) 
                      pair ` snd ` set (List.insert (i,t,s) D)"
    by (metis "5.IH")
  thus ?case by (auto simp add: setopssst_def)
next
  case (6 i t s A D)
  from 6 obtain Di A'' B C where A'':
      "Di  set (subseqs (dbproj i D))" "A''  set (trpc A [dD. d  set Di])" "A' = (B@C)@A''"
      "B = map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di"
      "C = map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) [ddbproj i D. d  set Di]"
    by moura
  hence "trmslst A''  trmssst (unlabel A)  pair ` setopssst (unlabel A) 
                       pair ` snd ` set [dD. d  set Di]"
    by (metis "6.IH")
  moreover have "set [dD. d  set Di]  set D" using set_filter by auto
  ultimately have
      "trmslst A''  trmssst (unlabel A)  pair ` setopssst (unlabel A)  pair ` snd ` set D"
    by blast
  hence "trmslst A''  trmssst (unlabel ((i,delete⟨t,s)#A)) 
                        pair ` setopssst (unlabel ((i,delete⟨t,s)#A)) 
                        pair ` snd ` set D"
    using setopssst_cons_subset trmssst_cons
    by (auto simp add: setopssst_def)
  moreover have "set Di  set D" "set [ddbproj i D . d  set Di]  set D"
    using subseqs_set_subset[OF A''(1)] by auto
  hence "trmsst (unlabel B)  insert (pair (t, s)) (pair ` snd ` set D)"
        "trmsst (unlabel C)  insert (pair (t, s)) (pair ` snd ` set D)"
    using A''(4,5) unfolding unlabel_def by auto
  hence "trmsst (unlabel (B@C))  insert (pair (t,s)) (pair ` snd ` set D)"
    using unlabel_append[of B C] by auto
  moreover have "pair (t,s)  pair ` setopssst (delete⟨t,s#unlabel A)" by (simp add: setopssst_def)
  ultimately show ?case
    using A''(3) trmsst_append[of "unlabel (B@C)" "unlabel A'"] unlabel_append[of "B@C" A'']
    by (auto simp add: setopssst_def)
next
  case (7 i ac t s A D)
  from 7 obtain d A'' where A'':
      "d  set (dbproj i D)" "A''  set (trpc A D)"
      "A' = (i,ac: (pair (t,s))  (pair (snd d))st)#A''"
    by moura
  hence "trmslst A''  trmssst (unlabel A)  pair ` setopssst (unlabel A) 
                       pair ` snd ` set D"
    by (metis "7.IH")
  moreover have "trmsst (unlabel A') = {pair (t,s), pair (snd d)}  trmsst (unlabel A'')"
    using A''(1,3) by auto
  ultimately show ?case using A''(1) by (auto simp add: setopssst_def)
next
  case (8 i X F F' A D)
  define constr where "constr = map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd (dbproj i D)))"
  define B where "B  (trmspairs ` set (trpairs F' (map snd (dbproj i D))))"

  from 8 obtain A'' where A'':
      "A''  set (trpc A D)" "A' = constr@A''"
    unfolding constr_def by moura

  have "trmsst (unlabel A'')  trmssst (unlabel A)  pair ` setopssst (unlabel A)  pair`snd`set D"
    by (metis A''(1) "8.IH")
  moreover have "trmsst (unlabel constr)  B  trmspairs F  pair ` snd ` set D"
    unfolding unlabel_def constr_def B_def by auto
  ultimately have "trmsst (unlabel A')  B  trmspairs F  trmssst (unlabel A) 
                                         pair ` setopssst (unlabel A)  pair ` snd ` set D"
    using A'' unlabel_append[of constr A''] by auto
  moreover have "set (dbproj i D)  set D" by auto
  hence "B  pair ` set F'  pair ` snd ` set D"
    using trpairs_trms_subset'[of F' "map snd (dbproj i D)"]
    unfolding B_def by force
  moreover have
      "pair ` setopssst (unlabel ((i, X⟨∨≠: F ∨∉: F')#A)) =
       pair ` set F'  pair ` setopssst (unlabel A)"
    by auto
  ultimately show ?case by (auto simp add: setopssst_def)
qed

lemma tr_par_wf_trms:
  assumes "A'  set (trpc A [])" "wftrms (trmssst (unlabel A))"
  shows "wftrms (trmslst A')"
using tr_par_trms_subset[OF assms(1)] setopssst_wftrms(2)[OF assms(2)]
by auto

lemma tr_par_wf':
  assumes "fvpairs (unlabel D)  bvarssst (unlabel A) = {}"
  and "fvpairs (unlabel D)  X"
  and "wf'sst X (unlabel A)" "fvsst (unlabel A)  bvarssst (unlabel A) = {}"
  and "A'  set (trpc A D)"
  shows "wflst X A'"
proof -
  define P where
    "P = (λ(D::('fun,'var,'lbl) labeleddbstatelist) (A::('fun,'var,'lbl) labeled_stateful_strand).
          (fvpairs (unlabel D)  bvarssst (unlabel A) = {}) 
          fvsst (unlabel A)  bvarssst (unlabel A) = {})"

  have "P D A" using assms(1,4) by (simp add: P_def)
  with assms(5,3,2) show ?thesis
  proof (induction A arbitrary: X A' D)
    case Nil thus ?case by simp
  next
    case (Cons a A)
    obtain i s where i: "a = (i,s)" by (metis surj_pair)
    note prems = Cons.prems
    note IH = Cons.IH
    show ?case
    proof (cases s)
      case (Receive t)
      note si = Receive i
      then obtain A'' where A'': "A' = (i,receive⟨tst)#A''" "A''  set (trpc A D)" "fv t  X"
        using prems unlabel_Cons(1)[of i s A] by moura
      have *: "wf'sst X (unlabel A)"
              "fvpairs (unlabel D)  X"
              "P D A"
        using prems si apply (force, force)
        using prems(4) si unfolding P_def by fastforce
      show ?thesis using IH[OF A''(2) *] A''(1,3) by simp
    next
      case (Send t)
      note si = Send i
      then obtain A'' where A'': "A' = (i,send⟨tst)#A''" "A''  set (trpc A D)"
        using prems by moura
      have *: "wf'sst (X  fv t) (unlabel A)"
              "fvpairs (unlabel D)  X  fv t"
              "P D A"
        using prems si apply (force, force)
        using prems(4) si unfolding P_def by fastforce
      show ?thesis using IH[OF A''(2) *] A''(1) by simp
    next
      case (Equality ac t t')
      note si = Equality i
      then obtain A'' where A'':
          "A' = (i,ac: t  t'st)#A''" "A''  set (trpc A D)"
          "ac = Assign  fv t'  X"
        using prems unlabel_Cons(1)[of i s] by moura
      have *: "ac = Assign  wf'sst (X  fv t) (unlabel A)"
              "ac = Check  wf'sst X (unlabel A)"
              "ac = Assign  fvpairs (unlabel D)  X  fv t"
              "ac = Check  fvpairs (unlabel D)  X"
              "P D A"
        using prems si apply (force, force, force, force)
        using prems(4) si unfolding P_def by fastforce
      show ?thesis
        using IH[OF A''(2) *(1,3,5)] IH[OF A''(2) *(2,4,5)] A''(1,3)
        by (cases ac) simp_all
    next
      case (Insert t t')
      note si = Insert i
      hence A': "A'  set (trpc A (List.insert (i,t,t') D))" "fv t  X" "fv t'  X"
        using prems by auto
      have *: "wf'sst X (unlabel A)" "fvpairs (unlabel (List.insert (i,t,t') D))  X"
        using prems si by (auto simp add: unlabel_def)
      have **: "P (List.insert (i,t,t') D) A"
        using prems(4) si
        unfolding P_def unlabel_def
        by fastforce
      show ?thesis using IH[OF A'(1) * **] A'(2,3) by simp
    next
      case (Delete t t')
      note si = Delete i
      define constr where "constr = (λDi.
        (map (λd. (i,check: (pair (t,t'))  (pair (snd d))st)) Di)@
        (map (λd. (i,[]⟨∨≠: [(pair (t,t'), pair (snd d))]st)) [ddbproj i D. d  set Di]))"
      from prems si obtain Di A'' where A'':
          "A' = constr Di@A''" "A''  set (trpc A [dD. d  set Di])"
          "Di  set (subseqs (dbproj i D))"
        unfolding constr_def by auto
      have *: "wf'sst X (unlabel A)"
              "fvpairs (unlabel (filter (λd. d  set Di) D))  X"
        using prems si apply simp
        using prems si by (fastforce simp add: unlabel_def)

      have "fvpairs (unlabel (filter (λd. d  set Di) D))  fvpairs (unlabel D)"
        by (auto simp add: unlabel_def)
      hence **: "P [dD. d  set Di] A"
        using prems si unfolding P_def
        by fastforce

      have ***: "fvpairs (unlabel D)  X" using prems si by auto
      show ?thesis
        using IH[OF A''(2) * **] A''(1) wf_pair_eqs_ineqs_map'[OF _ A''(3) ***]
        unfolding constr_def by simp
    next
      case (InSet ac t t')
      note si = InSet i
      then obtain d A'' where A'':
          "A' = (i,ac: (pair (t,t'))  (pair (snd d))st)#A''"
          "A''  set (trpc A D)"
          "d  set D"
        using prems by moura
      have *:
          "ac = Assign  wf'sst (X  fv t  fv t') (unlabel A)"
          "ac = Check  wf'sst X (unlabel A)"
          "ac = Assign  fvpairs (unlabel D)  X  fv t  fv t'"
          "ac = Check  fvpairs (unlabel D)  X"
          "P D A"
        using prems si apply (force, force, force, force)
        using prems(4) si unfolding P_def by fastforce
      have **: "fv (pair (snd d))  X"
        using A''(3) prems(3) fv_pair_fvpairs_subset
        by fast
      have ***: "fv (pair (t,t')) = fv t  fv t'" unfolding pair_def by auto
      show ?thesis
        using IH[OF A''(2) *(1,3,5)] IH[OF A''(2) *(2,4,5)] A''(1) ** ***
        by (cases ac) (simp_all add: Un_assoc)
    next
      case (NegChecks Y F F')
      note si = NegChecks i
      then obtain A'' where A'':
          "A' = (map (λG. (i,Y⟨∨≠: (F@G)st)) (trpairs F' (map snd (dbproj i D))))@A''"
          "A''  set (trpc A D)"
        using prems by moura

      have *: "wf'sst X (unlabel A)" "fvpairs (unlabel D)  X" using prems si by auto

      have "bvarssst (unlabel A)  bvarssst (unlabel ((i,Y⟨∨≠: F ∨∉: F')#A))"
           "fvsst (unlabel A)  fvsst (unlabel ((i,Y⟨∨≠: F ∨∉: F')#A))"
        by auto
      hence **:  "P D A" using prems si unfolding P_def by blast

      show ?thesis using IH[OF A''(2) * **] A''(1) wf_pair_negchecks_map' by simp
    qed
  qed
qed

lemma tr_par_wf:
  assumes "A'  set (trpc A [])"
    and "wfsst (unlabel A)"
    and "wftrms (trmslsst A)"
  shows "wflst {} A'"
    and "wftrms (trmslst A')"
    and "fvlst A'  bvarslst A' = {}"
using tr_par_wf'[OF _ _ _ _ assms(1)]
      tr_par_wf_trms[OF assms(1,3)]
      tr_par_vars_disj[OF assms(1)]
      assms(2)
by fastforce+

lemma tr_par_tfrsstp:
  assumes "A'  set (trpc A D)" "list_all tfrsstp (unlabel A)"
  and "fvsst (unlabel A)  bvarssst (unlabel A) = {}" (is "?P0 A D")
  and "fvpairs (unlabel D)  bvarssst (unlabel A) = {}" (is "?P1 A D")
  and "t  pair ` setopssst (unlabel A)  pair ` snd ` set D.
       t'  pair ` setopssst (unlabel A)  pair ` snd ` set D.
          (δ. Unifier δ t t')  Γ t = Γ t'" (is "?P3 A D")
  shows "list_all tfrstp (unlabel A')"
proof -
  have sublmm: "list_all tfrsstp (unlabel A)" "?P0 A D" "?P1 A D" "?P3 A D"
    when p: "list_all tfrsstp (unlabel (a#A))" "?P0 (a#A) D" "?P1 (a#A) D" "?P3 (a#A) D"
    for a A D
  proof -
    show "list_all tfrsstp (unlabel A)" using p(1) by (simp add: unlabel_def tfrsst_def)
    show "?P0 A D" using p(2) fvsst_cons_subset unfolding unlabel_def by fastforce
    show "?P1 A D" using p(3) bvarssst_cons_subset unfolding unlabel_def by fastforce
    have "setopssst (unlabel A)  setopssst (unlabel (a#A))"
      using setopssst_cons_subset unfolding unlabel_def by auto
    thus "?P3 A D" using p(4) by blast
  qed

  show ?thesis using assms
  proof (induction A D arbitrary: A' rule: trpc.induct)
    case 1 thus ?case by simp
  next
    case (2 i t A D)
    note prems = "2.prems"
    note IH = "2.IH"
    from prems(1) obtain A'' where A'': "A' = (i,send⟨tst)#A''" "A''  set (trpc A D)" by moura
    have "list_all tfrstp (unlabel A'')"
      using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)]
      by meson
    thus ?case using A''(1) by simp
  next
    case (3 i t A D)
    note prems = "3.prems"
    note IH = "3.IH"
    from prems(1) obtain A'' where A'': "A' = (i,receive⟨tst)#A''" "A''  set (trpc A D)" by moura
    have "list_all tfrstp (unlabel A'')"
      using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)]
      by meson
    thus ?case using A''(1) by simp
  next
    case (4 i ac t t' A D)
    note prems = "4.prems"
    note IH = "4.IH"
    from prems(1) obtain A'' where A'': "A' = (i,ac: t  t'st)#A''" "A''  set (trpc A D)" by moura
    have "list_all tfrstp (unlabel A'')"
      using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)]
      by meson
    thus ?case using A''(1) prems(2) by simp
  next
    case (5 i t s A D)
    note prems = "5.prems"
    note IH = "5.IH"
    from prems(1) have A': "A'  set (trpc A (List.insert (i,t,s) D))" by simp

    have 1: "list_all tfrsstp (unlabel A)" using sublmm[OF prems(2,3,4,5)] by simp

    have "pair ` setopssst (unlabel ((i,insert⟨t,s)#A))  pair`snd`set D =
          pair ` setopssst (unlabel A)  pair`snd`set (List.insert (i,t,s) D)"
      by (auto simp add: setopssst_def)
    hence 3: "?P3 A (List.insert (i,t,s) D)" using prems(5) by metis
    moreover have "?P1 A (List.insert (i,t,s) D)"
      using prems(3,4) bvarssst_cons_subset[of "unlabel A" "insert⟨t,s"]
      unfolding unlabel_def
      by fastforce
    ultimately have "list_all tfrstp (unlabel A')"
      using IH[OF A' sublmm(1,2)[OF prems(2,3,4,5)] _ 3] by metis
    thus ?case using A'(1) by auto
  next
    case (6 i t s A D)
    note prems = "6.prems"
    note IH = "6.IH"

    define constr where constr: "constr  (λDi.
      (map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di)@
      (map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) (filter (λd. d  set Di) (dbproj i D))))"

    from prems(1) obtain Di A'' where A'':
        "A' = constr Di@A''" "A''  set (trpc A (filter (λd. d  set Di) D))"
        "Di  set (subseqs (dbproj i D))"
      unfolding constr by fastforce

    define Q1 where "Q1  (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
        x  (fvpairs F) - set X. a. Γ (Var x) = TAtom a)"
    define Q2 where "Q2  (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
        f T. Fun f T  subtermsset (trmspairs F)  T = []  (s  set T. s  Var ` set X))"

    have "pair ` setopssst (unlabel A)  pair`snd`set [dD. d  set Di]
             pair ` setopssst (unlabel ((i,delete⟨t,s)#A))  pair`snd`set D"
      using subseqs_set_subset[OF A''(3)] by (force simp add: setopssst_def)
    moreover have "aM. bM. P a b"
      when "M  N" "aN. bN. P a b"
      for M N::"('fun, 'var) terms" and  P
      using that by blast
    ultimately have *: "?P3 A (filter (λd. d  set Di) D)"
      using prems(5) by presburger

    have **: "?P1 A (filter (λd. d  set Di) D)"
      using prems(4) bvarssst_cons_subset[of "unlabel A" "delete⟨t,s"]
      unfolding unlabel_def by fastforce

    have 1: "list_all tfrstp (unlabel A'')"
      using IH[OF A''(3,2) sublmm(1,2)[OF prems(2,3,4,5)] ** *]
      by metis

    have 2: "ac: u  u'st  set (unlabel A'') 
             (d  set Di. u = pair (t,s)  u' = pair (snd d))"
      when "ac: u  u'st  set (unlabel A')" for ac u u'
      using that A''(1) unfolding constr unlabel_def by force
    have 3:
        "X⟨∨≠: ust  set (unlabel A'') 
         (d  set (filter (λd. d  set Di) D). u = [(pair (t,s), pair (snd d))]  Q2 u X)"
      when "X⟨∨≠: ust  set (unlabel A')" for X u
      using that A''(1) unfolding Q2_def constr unlabel_def by force
    have 4: "dset D. (δ. Unifier δ (pair (t,s)) (pair (snd d)))
                        Γ (pair (t,s)) = Γ (pair (snd d))"
      using prems(5) by (simp add: setopssst_def)

    { fix ac u u'
      assume a: "ac: u  u'st  set (unlabel A')" "δ. Unifier δ u u'"
      hence "ac: u  u'st  set (unlabel A'')  (d  set Di. u = pair (t,s)  u' = pair (snd d))"
        using 2 by metis
      moreover {
        assume "ac: u  u'st  set (unlabel A'')"
        hence "tfrstp (ac: u  u'st)"
          using 1 Ball_set_list_all[of "unlabel A''" tfrstp]
          by fast
      } moreover {
        fix d assume "d  set Di" "u = pair (t,s)" "u' = pair (snd d)"
        hence "δ. Unifier δ u u'  Γ u = Γ u'"
          using 4 dbproj_subseq_subset A''(3)
          by fast
        hence "tfrstp (ac: u  u'st)"
          using Ball_set_list_all[of "unlabel A''" tfrstp]
          by simp
        hence "Γ u = Γ u'" using tfrstp_list_all_alt_def[of "unlabel A''"]
          using a(2) unfolding unlabel_def by auto
      } ultimately have "Γ u = Γ u'"
          using tfrstp_list_all_alt_def[of "unlabel A''"] a(2)
          unfolding unlabel_def by auto
    } moreover {
      fix u U
      assume "U⟨∨≠: ust  set (unlabel A')"
      hence "U⟨∨≠: ust  set (unlabel A'') 
             (d  set (filter (λd. d  set Di) D). u = [(pair (t,s), pair (snd d))]  Q2 u U)"
        using 3 by metis
      hence "Q1 u U  Q2 u U"
        using 1 4 subseqs_set_subset[OF A''(3)] tfrstp_list_all_alt_def[of "unlabel A''"]
        unfolding Q1_def Q2_def
        by blast
    } ultimately show ?case
      using tfrstp_list_all_alt_def[of "unlabel A'"] unfolding Q1_def Q2_def unlabel_def by blast
  next
    case (7 i ac t s A D)
    note prems = "7.prems"
    note IH = "7.IH"

    from prems(1) obtain d A'' where A'':
        "A' = (i,ac: (pair (t,s))  (pair (snd d))st)#A''"
        "A''  set (trpc A D)"
        "d  set (dbproj i D)"
      by moura

    have 1: "list_all tfrstp (unlabel A'')"
      using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]]
      by metis

    have 2: "Γ (pair (t,s)) = Γ (pair (snd d))"
      when "δ. Unifier δ (pair (t,s)) (pair (snd d))"
      using that prems(2,5) A''(3) unfolding tfrsst_def by (simp add: setopssst_def)

    show ?case using A''(1) 1 2 by fastforce
  next
    case (8 i X F F' A D)
    note prems = "8.prems"
    note IH = "8.IH"

    define constr where
      "constr = map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd (dbproj i D)))"

    define Q1 where "Q1  (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
        x  (fvpairs F) - set X. a. Γ (Var x) = TAtom a)"

    define Q2 where "Q2  (λ(M::('fun,'var) terms) X.
        f T. Fun f T  subtermsset M  T = []  (s  set T. s  Var ` set X))"

    have Q2_subset: "Q2 M' X" when "M'  M" "Q2 M X" for X M M'
      using that unfolding Q2_def by auto

    have Q2_supset: "Q2 (M  M') X" when "Q2 M X" "Q2 M' X" for X M M'
      using that unfolding Q2_def by auto

    from prems obtain A'' where A'': "A' = constr@A''" "A''  set (trpc A D)"
      using constr_def by moura

    have 0: "constr = [(i,X⟨∨≠: Fst)]" when "F' = []" using that unfolding constr_def by simp

    have 1: "list_all tfrstp (unlabel A'')"
      using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]]
      by metis

    have 2: "(F' = []  Q1 F X)  Q2 (trmspairs F  pair ` set F') X"
      using prems(2) unfolding Q1_def Q2_def by simp

    have 3: "F' = []  Q1 F X  list_all tfrstp (unlabel constr)"
      using 0 2 tfrstp_list_all_alt_def[of "unlabel constr"] unfolding Q1_def by auto

    { fix c assume "c  set (unlabel constr)"
      hence "G  set (trpairs F' (map snd (dbproj i D))). c = X⟨∨≠: (F@G)st"
        unfolding constr_def unlabel_def by force
    } moreover {
      fix G
      assume G: "G  set (trpairs F' (map snd (dbproj i D)))"
         and c: "X⟨∨≠: (F@G)st  set (unlabel constr)"
         and e: "Q2 (trmspairs F  pair ` set F') X"

      have d_Q2: "Q2 (pair ` set (map snd D)) X" unfolding Q2_def
      proof (intro allI impI)
        fix f T assume "Fun f T  subtermsset (pair ` set (map snd D))"
        then obtain d where d: "d  set (map snd D)" "Fun f T  subterms (pair d)" by force
        hence "fv (pair d)  set X = {}"
          using prems(4) unfolding pair_def by (force simp add: unlabel_def)
        thus "T = []  (s  set T. s  Var ` set X)"
          by (metis fv_disj_Fun_subterm_param_cases d(2))
      qed

      have "trmspairs (F@G)  trmspairs F  pair ` set F'  pair ` set (map snd D)"
        using trpairs_trms_subset[OF G] by force
      hence "Q2 (trmspairs (F@G)) X" using Q2_subset[OF _ Q2_supset[OF e d_Q2]] by metis
      hence "tfrstp (X⟨∨≠: (F@G)st)" by (metis Q2_def tfrstp.simps(2))
    } ultimately have 4:
        "Q2 (trmspairs F  pair ` set F') X  list_all tfrstp (unlabel constr)"
      using Ball_set by blast

    have 5: "list_all tfrstp (unlabel constr)" using 2 3 4 by metis

    show ?case using 1 5 A''(1) by (simp add: unlabel_def)
  qed
qed

lemma tr_par_tfr:
  assumes "A'  set (trpc A [])" and "tfrsst (unlabel A)"
    and "fvsst (unlabel A)  bvarssst (unlabel A) = {}"
  shows "tfrst (unlabel A')"
proof -
  have *: "trmslst A'  trmssst (unlabel A)  pair ` setopssst (unlabel A)"
    using tr_par_trms_subset[OF assms(1)] by simp
  hence "SMP (trmslst A')  SMP (trmssst (unlabel A)  pair ` setopssst (unlabel A))"
    using SMP_mono by simp
  moreover have "tfrset (trmssst (unlabel A)  pair ` setopssst (unlabel A))"
    using assms(2) unfolding tfrsst_def by fast
  ultimately have 1: "tfrset (trmslst A')" by (metis tfr_subset(2)[OF _ *])

  have **: "list_all tfrsstp (unlabel A)" using assms(2) unfolding tfrsst_def by fast
  have "pair ` setopssst (unlabel A) 
        SMP (trmssst (unlabel A)  pair ` setopssst (unlabel A)) - Var`𝒱"
    using setopssst_are_pairs unfolding pair_def by auto
  hence "Γ t = Γ t'"
    when "δ. Unifier δ t t'" "t  pair ` setopssst (unlabel A)" "t'  pair ` setopssst (unlabel A)"
    for t t'
    using that assms(2) unfolding tfrsst_def tfrset_def by blast
  moreover have "fvpairs (unlabel []) = {}" "pair ` snd ` set [] = {}" by auto
  ultimately have 2: "list_all tfrstp (unlabel A')"
    using tr_par_tfrsstp[OF assms(1) ** assms(3)] by simp

  show ?thesis by (metis 1 2 tfrst_def)
qed

lemma tr_par_proj:
  assumes "B  set (trpc A D)"
  shows "proj n B  set (trpc (proj n A) (proj n D))"
using assms
proof (induction A D arbitrary: B rule: trpc.induct)
  case (5 i t s S D)
  note prems = "5.prems"
  note IH = "5.IH"
  have IH': "proj n B  set (trpc (proj n S) (proj n (List.insert (i,t,s) D)))"
    using prems IH by auto
  show ?case
  proof (cases "(i = ln n)  (i = )")
    case True thus ?thesis
      using IH' proj_list_insert(1,2)[of n "(t,s)" D] proj_list_Cons(1,2)[of n _ S]
      by auto
  next
    case False
    then obtain m where "i = ln m" "n  m" by (cases i) simp_all
    thus ?thesis
      using IH' proj_list_insert(3)[of n _ "(t,s)" D] proj_list_Cons(3)[of n _ "insert⟨t,s" S]
      by auto
  qed
next
  case (6 i t s S D)
  note prems = "6.prems"
  note IH = "6.IH"
  define constr where "constr = (λDi D.
      (map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di)@
      (map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) [ddbproj i D. d  set Di]))"

  obtain Di B' where B':
      "B = constr Di D@B'"
      "Di  set (subseqs (dbproj i D))"
      "B'  set (trpc S [dD. d  set Di])"
    using prems constr_def by fastforce
  hence "proj n B'  set (trpc (proj n S) (proj n [dD. d  set Di]))" using IH by simp
  hence IH': "proj n B'  set (trpc (proj n S) [dproj n D. d  set Di])" by (metis proj_filter)
  show ?case
  proof (cases "(i = ln n)  (i = )")
    case True
    hence "proj n B = constr Di D@proj n B'" "Di  set (subseqs (dbproj i (proj n D)))"
      using B'(1,2) proj_dbproj(1,2)[of n D] unfolding proj_def constr_def by auto
    moreover have "constr Di (proj n D) = constr Di D"
      using True proj_dbproj(1,2)[of n D] unfolding constr_def by presburger
    ultimately have "proj n B  set (trpc ((i, delete⟨t,s)#proj n S) (proj n D))"
      using IH' unfolding constr_def by force
    thus ?thesis by (metis proj_list_Cons(1,2) True)
  next
    case False
    then obtain m where m: "i = ln m" "n  m" by (cases i) simp_all
    hence *: "(ln n)  i" by simp
    have "proj n B = proj n B'" using B'(1) False unfolding constr_def proj_def by auto
    moreover have "[dproj n D. d  set Di] = proj n D"
      using proj_subseq[OF _ m(2)[symmetric]] m(1) B'(2) by simp
    ultimately show ?thesis using m(1) IH' proj_list_Cons(3)[OF m(2), of _ S] by auto
  qed
next
  case (7 i ac t s S D)
  note prems = "7.prems"
  note IH = "7.IH"
  define constr where "constr = (
    λd::'lbl strand_label × ('fun,'var) term × ('fun,'var) term.
      (i,ac: (pair (t,s))  (pair (snd d))st))"

  obtain d B' where B':
      "B = constr d#B'"
      "d  set (dbproj i D)"
      "B'  set (trpc S D)"
    using prems constr_def by fastforce
  hence IH': "proj n B'  set (trpc (proj n S) (proj n D))" using IH by auto

  show ?case
  proof (cases "(i = ln n)  (i = )")
    case True
    hence "proj n B = constr d#proj n B'" "d  set (dbproj i (proj n D))"
      using B' proj_list_Cons(1,2)[of n _ B']
      unfolding constr_def
      by (force, metis proj_dbproj(1,2))
    hence "proj n B  set (trpc ((i, InSet ac t s)#proj n S) (proj n D))"
      using IH' unfolding constr_def by auto
    thus ?thesis using proj_list_Cons(1,2)[of n _ S] True by metis
  next
    case False
    then obtain m where m: "i = ln m" "n  m" by (cases i) simp_all
    hence "proj n B = proj n B'" using B'(1) proj_list_Cons(3) unfolding constr_def by auto
    thus ?thesis
      using IH' m proj_list_Cons(3)[OF m(2), of "InSet ac t s" S]
      unfolding constr_def
      by auto
  qed
next
  case (8 i X F F' S D)
  note prems = "8.prems"
  note IH = "8.IH"

  define constr where
    "constr = (λD. map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd (dbproj i D))))"

  obtain B' where B':
      "B = constr D@B'"
      "B'  set (trpc S D)"
    using prems constr_def by fastforce
  hence IH': "proj n B'  set (trpc (proj n S) (proj n D))" using IH by auto

  show ?case
  proof (cases "(i = ln n)  (i = )")
    case True
    hence "proj n B = constr (proj n D)@proj n B'"
      using B'(1,2) proj_dbproj(1,2)[of n D] unfolding proj_def constr_def by auto
    hence "proj n B  set (trpc ((i, NegChecks X F F')#proj n S) (proj n D))"
      using IH' unfolding constr_def by auto
    thus ?thesis using proj_list_Cons(1,2)[of n _ S] True by metis
  next
    case False
    then obtain m where m: "i = ln m" "n  m" by (cases i) simp_all
    hence "proj n B = proj n B'" using B'(1) unfolding constr_def proj_def by auto
    thus ?thesis
      using IH' m proj_list_Cons(3)[OF m(2), of "NegChecks X F F'" S]
      unfolding constr_def
      by auto
  qed
qed (force simp add: proj_def)+

lemma tr_par_preserves_typing_cond:
  assumes "par_complsst A Sec" "typing_condsst (unlabel A)" "A'  set (trpc A [])"
  shows "typing_cond (unlabel A')"
proof -
  have "wf'sst {} (unlabel A)"
       "fvsst (unlabel A)  bvarssst (unlabel A) = {}"
       "wftrms (trmssst (unlabel A))"
    using assms(2) unfolding typing_condsst_def by simp_all
  hence 1: "wfst {} (unlabel A')"
           "fvst (unlabel A')  bvarsst (unlabel A') = {}"
           "wftrms (trmsst (unlabel A'))"
           "Ana_invar_subst (ikst (unlabel A')  assignment_rhsst (unlabel A'))"
    using tr_par_wf[OF assms(3)] Ana_invar_subst' by metis+

  have 2: "tfrst (unlabel A')" by (metis tr_par_tfr assms(2,3) typing_condsst_def)

  show ?thesis by (metis 1 2 typing_cond_def)
qed

lemma tr_par_preserves_par_comp:
  assumes "par_complsst A Sec" "A'  set (trpc A [])"
  shows "par_comp A' Sec"
proof -
  let ?M = "λl. trmssst (proj_unl l A)  pair ` setopssst (proj_unl l A)"
  let ?N = "λl. trms_projlst l A'"

  have 0: "l1 l2. l1  l2  GSMP_disjoint (?M l1) (?M l2) Sec"
    using assms(1) unfolding par_complsst_def by simp_all

  { fix l1 l2::'lbl assume *: "l1  l2"
    hence "GSMP_disjoint (?M l1) (?M l2) Sec" using 0(1) by metis
    moreover have "pair ` snd ` set (proj n []) = {}" for n::'lbl unfolding proj_def by simp
    hence "?N l1  ?M l1" "?N l2  ?M l2"
      using tr_par_trms_subset[OF tr_par_proj[OF assms(2)]] by (metis Un_empty_right)+
    ultimately have "GSMP_disjoint (?N l1) (?N l2) Sec"
      using GSMP_disjoint_subset by presburger
  } hence 1: "l1 l2. l1  l2  GSMP_disjoint (trms_projlst l1 A') (trms_projlst l2 A') Sec"
    using 0(1) by metis

  have 2: "ground Sec" "s  Sec. s'  subterms s. {} c s'  s'  Sec"
    using assms(1) unfolding par_complsst_def by metis+

  show ?thesis using 1 2 unfolding par_comp_def by metis
qed

lemma tr_leaking_prefix_exists:
  assumes "A'  set (trpc A [])" "prefix B A'" "ikst (proj_unl n B) set   t  "
  shows "C D. prefix C B  prefix D A  C  set (trpc D [])  (ikst (proj_unl n C) set   t  )"
proof -
  let ?P = "λB C C'. B = C@C'  (n t. (n, receive⟨tst)  set C') 
                     (C = []  (n t. suffix [(n,receive⟨tst)] C))"
  have "C C'. ?P B C C'"
  proof (induction B)
    case (Cons b B)
    then obtain C C' n s where *: "?P B C C'" "b = (n,s)" by moura
    show ?case
    proof (cases "C = []")
      case True
      note T = True
      show ?thesis
      proof (cases "t. s = receive⟨tst")
        case True
        hence "?P (b#B) [b] C'" using * T  by auto
        thus ?thesis by metis
      next
        case False
        hence "?P (b#B) [] (b#C')" using * T by auto
        thus ?thesis by metis
      qed
    next
      case False
      hence "?P (b#B) (b#C) C'" using * unfolding suffix_def by auto
      thus ?thesis by metis
    qed
  qed simp
  then obtain C C' where C:
      "B = C@C'" "n t. (n, receive⟨tst)  set C'"
      "C = []  (n t. suffix [(n,receive⟨tst)] C)"
    by moura
  hence 1: "prefix C B" by simp
  hence 2: "prefix C A'" using assms(2) by simp

  have "m t. (m,receive⟨tst)  set B  (m,receive⟨tst)  set C" using C by auto
  hence "t. receive⟨tst  set (proj_unl n B)  receive⟨tst  set (proj_unl n C)"
    unfolding unlabel_def proj_def by force
  hence "ikst (proj_unl n B)  ikst (proj_unl n C)" using ikst_is_rcv_set by auto
  hence 3: "ikst (proj_unl n C) set   t  " by (metis ideduct_mono[OF assms(3)] subst_all_mono)

  { fix D E m t assume  "suffix [(m, receive⟨tst)] E" "prefix E A'" "A'  set (trpc A D)"
    hence "F. prefix F A  E  set (trpc F D)"
    proof (induction A D arbitrary: A' E rule: trpc.induct)
      case (1 D) thus ?case by simp
    next
      case (2 i t' S D)
      note prems = "2.prems"
      note IH = "2.IH"
      obtain A'' where *: "A' = (i,send⟨t'st)#A''" "A''  set (trpc S D)"
        using prems(3) by auto
      have "E  []" using prems(1) by auto
      then obtain E' where **: "E = (i,send⟨t'st)#E'"
        using *(1) prems(2) by (cases E) auto
      hence "suffix [(m, receive⟨tst)] E'" "prefix E' A''"
        using *(1) prems(1,2) suffix_Cons[of _ _ E'] by auto
      then obtain F where "prefix F S" "E'  set (trpc F D)"
        using *(2) ** IH by metis
      hence "prefix ((i,Send t')#F) ((i,Send t')#S)" "E  set (trpc ((i,Send t')#F) D)"
        using ** by auto
      thus ?case by metis
    next
      case (3 i t' S D)
      note prems = "3.prems"
      note IH = "3.IH"
      obtain A'' where *: "A' = (i,receive⟨t'st)#A''" "A''  set (trpc S D)"
        using prems(3) by auto
      have "E  []" using prems(1) by auto
      then obtain E' where **: "E = (i,receive⟨t'st)#E'"
        using *(1) prems(2) by (cases E) auto
      show ?case
      proof (cases "(m, receive⟨tst) = (i, receive⟨t'st)")
        case True
        note T = True
        show ?thesis
        proof (cases "suffix [(m, receive⟨tst)] E'")
          case True
          hence "suffix [(m, receive⟨tst)] E'" "prefix E' A''"
            using ** *(1) prems(1,2) by auto
          then obtain F where "prefix F S" "E'  set (trpc F D)"
            using *(2) ** IH by metis
          hence "prefix ((i,receive⟨t')#F) ((i,receive⟨t')#S)"
                "E  set (trpc ((i,receive⟨t')#F) D)"
            using ** by auto
          thus ?thesis by metis
        next
          case False
          hence "E' = []"
            using **(1) T prems(1)
                  suffix_Cons[of "[(m, receive⟨tst)]" "(m, receive⟨tst)" E']
            by auto
          hence "prefix [(i,receive⟨t')] ((i,receive⟨t') # S)  E  set (trpc [(i,receive⟨t')] D)"
            using * ** prems by auto
          thus ?thesis by metis
        qed
      next
        case False
        hence "suffix [(m, receive⟨tst)] E'" "prefix E' A''"
          using ** *(1) prems(1,2) suffix_Cons[of _ _ E'] by auto
        then obtain F where "prefix F S" "E'  set (trpc F D)" using *(2) ** IH by metis
        hence "prefix ((i,receive⟨t')#F) ((i,receive⟨t')#S)" "E  set (trpc ((i,receive⟨t')#F) D)"
          using ** by auto
        thus ?thesis by metis
      qed
    next
      case (4 i ac t' t'' S D)
      note prems = "4.prems"
      note IH = "4.IH"
      obtain A'' where *: "A' = (i,ac: t'  t''st)#A''" "A''  set (trpc S D)"
        using prems(3) by auto
      have "E  []" using prems(1) by auto
      then obtain E' where **: "E = (i,ac: t'  t''st)#E'"
        using *(1) prems(2) by (cases E) auto
      hence "suffix [(m, receive⟨tst)] E'" "prefix E' A''"
        using *(1) prems(1,2) suffix_Cons[of _ _ E'] by auto
      then obtain F where "prefix F S" "E'  set (trpc F D)"
        using *(2) ** IH by metis
      hence "prefix ((i,Equality ac t' t'')#F) ((i,Equality ac t' t'')#S)"
            "E  set (trpc ((i,Equality ac t' t'')#F) D)"
        using ** by auto
      thus ?case by metis
    next
      case (5 i t' s S D)
      note prems = "5.prems"
      note IH = "5.IH"
      have *: "A'  set (trpc S (List.insert (i,t',s) D))" using prems(3) by auto
      have "E  []" using prems(1) by auto
      hence "suffix [(m, receive⟨tst)] E" "prefix E A'"
        using *(1) prems(1,2) suffix_Cons[of _ _ E] by auto
      then obtain F where "prefix F S" "E  set (trpc F (List.insert (i,t',s) D))"
        using * IH by metis
      hence "prefix ((i,insert⟨t',s)#F) ((i,insert⟨t',s)#S)"
            "E  set (trpc ((i,insert⟨t',s)#F) D)"
        by auto
      thus ?case by metis
    next
      case (6 i t' s S D)
      note prems = "6.prems"
      note IH = "6.IH"

      define constr where "constr = (λDi.
        (map (λd. (i,check: (pair (t',s))  (pair (snd d))st)) Di)@
        (map (λd. (i,[]⟨∨≠: [(pair (t',s), pair (snd d))]st))
          (filter (λd. d  set Di) (dbproj i D))))"

      obtain A'' Di where *:
          "A' = constr Di@A''" "A''  set (trpc S (filter (λd. d  set Di) D))"
          "Di  set (subseqs (dbproj i D))"
        using prems(3) constr_def by auto
      have ***:  "(m, receive⟨tst)  set (constr Di)" using constr_def by auto
      have "E  []" using prems(1) by auto
      then obtain E' where **: "E = constr Di@E'"
        using *(1) prems(1,2) ***
        by (metis (mono_tags, lifting) Un_iff list.set_intros(1) prefixI prefix_def
                                       prefix_same_cases set_append suffix_def)
      hence "suffix [(m, receive⟨tst)] E'" "prefix E' A''"
        using *(1) prems(1,2) suffix_append[of "[(m,receive⟨tst)]" "constr Di" E'] ***
        by (metis (no_types, hide_lams) Nil_suffix append_Nil2 in_set_conv_decomp rev_exhaust
                                        snoc_suffix_snoc suffix_appendD,
            auto)
      then obtain F where "prefix F S" "E'  set (trpc F (filter (λd. d  set Di) D))"
        using *(2,3) ** IH by metis
      hence "prefix ((i,delete⟨t',s)#F) ((i,delete⟨t',s)#S)"
            "E  set (trpc ((i,delete⟨t',s)#F) D)"
        using *(3) ** constr_def by auto
      thus ?case by metis
    next
      case (7 i ac t' s S D)
      note prems = "7.prems"
      note IH = "7.IH"

      define constr where "constr = (
        λd::(('lbl strand_label × ('fun,'var) term × ('fun,'var) term)).
          (i,ac: (pair (t',s))  (pair (snd d))st))"

      obtain A'' d where *: "A' = constr d#A''" "A''  set (trpc S D)" "d  set (dbproj i D)"
        using prems(3) constr_def by auto
      have "E  []" using prems(1) by auto
      then obtain E' where **: "E = constr d#E'" using *(1) prems(2) by (cases E) auto
      hence "suffix [(m, receive⟨tst)] E'" "prefix E' A''"
        using *(1) prems(1,2) suffix_Cons[of _ _ E'] using constr_def by auto
      then obtain F where "prefix F S" "E'  set (trpc F D)" using *(2) ** IH by metis
      hence "prefix ((i,InSet ac t' s)#F) ((i,InSet ac t' s)#S)"
            "E  set (trpc ((i,InSet ac t' s)#F) D)"
        using *(3) ** unfolding constr_def by auto
      thus ?case by metis
    next
      case (8 i X G G' S D)
      note prems = "8.prems"
      note IH = "8.IH"

      define constr where
        "constr = map (λH. (i,X⟨∨≠: (G@H)st)) (trpairs G' (map snd (dbproj i D)))"

      obtain A'' where *: "A' = constr@A''" "A''  set (trpc S D)"
        using prems(3) constr_def by auto
      have ***:  "(m, receive⟨tst)  set constr" using constr_def by auto
      have "E  []" using prems(1) by auto
      then obtain E' where **: "E = constr@E'"
        using *(1) prems(1,2) ***
        by (metis (mono_tags, lifting) Un_iff list.set_intros(1) prefixI prefix_def
                                       prefix_same_cases set_append suffix_def)
      hence "suffix [(m, receive⟨tst)] E'" "prefix E' A''"
        using *(1) prems(1,2) suffix_append[of "[(m,receive⟨tst)]" constr E'] ***
        by (metis (no_types, hide_lams) Nil_suffix append_Nil2 in_set_conv_decomp rev_exhaust
                                        snoc_suffix_snoc suffix_appendD,
            auto)
      then obtain F where "prefix F S" "E'  set (trpc F D)" using *(2) ** IH by metis
      hence "prefix ((i,NegChecks X G G')#F) ((i,NegChecks X G G')#S)"
            "E  set (trpc ((i,NegChecks X G G')#F) D)"
        using ** constr_def by auto
      thus ?case by metis
    qed
  }
  moreover have "prefix [] A" "[]  set (trpc [] [])" by auto
  ultimately have 4: "D. prefix D A  C  set (trpc D [])" using C(3) assms(1) 2 by blast

  show ?thesis by (metis 1 3 4)
qed


subsection ‹Theorem: Semantic Equivalence of Translation›
context
begin

text ‹
  An alternative version of the translation that does not perform database-state projections.
  It is used as an intermediate step in the proof of semantic equivalence.
›
private fun tr'pc::
  "('fun,'var,'lbl) labeled_stateful_strand  ('fun,'var,'lbl) labeleddbstatelist
    ('fun,'var,'lbl) labeled_strand list"
where
  "tr'pc [] D = [[]]"
| "tr'pc ((i,send⟨t)#A) D = map ((#) (i,send⟨tst)) (tr'pc A D)"
| "tr'pc ((i,receive⟨t)#A) D = map ((#) (i,receive⟨tst)) (tr'pc A D)"
| "tr'pc ((i,ac: t  t')#A) D = map ((#) (i,ac: t  t'st)) (tr'pc A D)"
| "tr'pc ((i,insert⟨t,s)#A) D = tr'pc A (List.insert (i,(t,s)) D)"
| "tr'pc ((i,delete⟨t,s)#A) D = (
    concat (map (λDi. map (λB. (map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di)@
                               (map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st))
                                    [dD. d  set Di])@B)
                          (tr'pc A [dD. d  set Di]))
                (subseqs D)))"
| "tr'pc ((i,ac: t  s)#A) D =
    concat (map (λB. map (λd. (i,ac: (pair (t,s))  (pair (snd d))st)#B) D) (tr'pc A D))"
| "tr'pc ((i,X⟨∨≠: F ∨∉: F')#A) D =
    map ((@) (map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd D)))) (tr'pc A D)"

subsubsection ‹Part 1›
private lemma tr'_par_iff_unlabel_tr:
  assumes "(i,p)  setopslsst A  set D.
           (j,q)  setopslsst A  set D.
              p = q  i = j"
  shows "(C  set (tr'pc A D). B = unlabel C)  B  set (tr (unlabel A) (unlabel D))"
    (is "?A  ?B")
proof
  { fix C have "C  set (tr'pc A D)  unlabel C  set (tr (unlabel A) (unlabel D))" using assms
    proof (induction A D arbitrary: C rule: tr'pc.induct)
      case (5 i t s S D)
      hence "unlabel C  set (tr (unlabel S) (unlabel (List.insert (i, t, s) D)))"
        by (auto simp add: setopslsst_def)
      moreover have
          "insert (i,t,s) (set D)  setopslsst ((i,insert⟨t,s)#S)  set D"
        by (auto simp add: setopslsst_def)
      hence "(j,p)  insert (i,t,s) (set D). (k,q)  insert (i,t,s) (set D). p = q  j = k"
        using "5.prems"(2) by blast
      hence "unlabel (List.insert (i, t, s) D) = (List.insert (t, s) (unlabel D))"
        using map_snd_list_insert_distrib[of "(i,t,s)" D] unfolding unlabel_def by simp
      ultimately show ?case by auto
    next
      case (6 i t s S D)
      let ?f1 = "λd. check: (pair (t,s))  (pair d)st"
      let ?g1 = "λd. []⟨∨≠: [(pair (t,s), pair d)]st"
      let ?f2 = "λd. (i, ?f1 (snd d))"
      let ?g2 = "λd. (i, ?g1 (snd d))"

      define constr1 where "constr1 = (λDi. (map ?f1 Di)@(map ?g1 [dunlabel D. d  set Di]))"
      define constr2 where "constr2 = (λDi. (map ?f2 Di)@(map ?g2 [dD. d  set Di]))"

      obtain C' Di where C':
          "Di  set (subseqs D)"
          "C = constr2 Di@C'"
          "C'  set (tr'pc S [dD. d  set Di])"
        using "6.prems"(1) unfolding constr2_def by moura

      have 0: "set [dD. d  set Di]  set D"
              "setopslsst S  setopslsst ((i, delete⟨t,s)#S)"
        by (auto simp add: setopslsst_def)
      hence 1:
          "(j, p)  setopslsst S  set [dD. d  set Di].
           (k, q)  setopslsst S  set [dD. d  set Di].
            p = q  j = k"
        using "6.prems"(2) by blast

      have "(i,p)  set D  set Di. (j,q)  set D  set Di. p = q  i = j"
        using "6.prems"(2) subseqs_set_subset(1)[OF C'(1)] by blast
      hence 2: "unlabel [dD. d  set Di] = [dunlabel D. d  set (unlabel Di)]"
        using unlabel_filter_eq[of D "set Di"] unfolding unlabel_def by simp

      have 3:
          "f g::('a × 'a  'c). A B::(('b × 'a × 'a) list).
              map snd ((map (λd. (i, f (snd d))) A)@(map (λd. (i, g (snd d))) B)) =
              map f (map snd A)@map g (map snd B)"
        by simp
      have "unlabel (constr2 Di) = constr1 (unlabel Di)"
        using 2 3[of ?f1 Di ?g1 "[dD. d  set Di]"]
        by (simp add: constr1_def constr2_def unlabel_def)
      hence 4: "unlabel C = constr1 (unlabel Di)@unlabel C'"
        using C'(2) unlabel_append by metis

      have "unlabel Di  set (map unlabel (subseqs D))"
        using C'(1) unfolding unlabel_def by simp
      hence 5: "unlabel Di  set (subseqs (unlabel D))"
        using map_subseqs[of snd D] unfolding unlabel_def by simp

      show ?case using "6.IH"[OF C'(1,3) 1] 2 4 5 unfolding constr1_def by auto
    next
      case (7 i ac t s S D)
      obtain C' d  where C':
          "C = (i,ac: (pair (t,s))  (pair (snd d))st)#C'"
          "C'  set (tr'pc S D)" "d  set D"
        using "7.prems"(1) by moura

      have "setopslsst S  set D  setopslsst ((i,InSet ac t s)#S)  set D"
        by (auto simp add: setopslsst_def)
      hence "(j, p)  setopslsst S  set D.
             (k, q)  setopslsst S  set D.
              p = q  j = k"
        using "7.prems"(2) by blast
      hence "unlabel C'  set (tr (unlabel S) (unlabel D))" using "7.IH"[OF C'(2)] by auto
      thus ?case using C' unfolding unlabel_def by force
    next
      case (8 i X F F' S D)
      obtain C' where C':
          "C = map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd D))@C'"
          "C'  set (tr'pc S D)"
        using "8.prems"(1) by moura

      have "setopslsst S  set D  setopslsst ((i,NegChecks X F F')#S)  set D"
        by (auto simp add: setopslsst_def)
      hence "(j, p)  setopslsst S  set D.
             (k, q)  setopslsst S  set D.
              p = q  j = k"
        using "8.prems"(2) by blast
      hence "unlabel C'  set (tr (unlabel S) (unlabel D))" using "8.IH"[OF C'(2)] by auto
      thus ?case using C' unfolding unlabel_def by auto
    qed (auto simp add: setopslsst_def)
  } thus "?A  ?B" by blast

  show "?B  ?A" using assms
  proof (induction A arbitrary: B D)
    case (Cons a A)
    obtain ia sa where a: "a = (ia,sa)" by moura

    have "setopslsst A  setopslsst (a#A)" using a by (cases sa) (auto simp add: setopslsst_def)
    hence 1: "(j, p)  setopslsst A  set D.
              (k, q)  setopslsst A  set D.
                p = q  j = k"
      using Cons.prems(2) by blast

    show ?case
    proof (cases sa)
      case (Send t)
      then obtain B' where B':
          "B = send⟨tst#B'"
          "B'  set (tr (unlabel A) (unlabel D))"
        using Cons.prems(1) a by auto
      thus ?thesis using Cons.IH[OF B'(2) 1] a B'(1) Send by auto
    next
      case (Receive t)
      then obtain B' where B':
          "B = receive⟨tst#B'"
          "B'  set (tr (unlabel A) (unlabel D))"
        using Cons.prems(1) a by auto
      thus ?thesis using Cons.IH[OF B'(2) 1] a B'(1) Receive by auto
    next
      case (Equality ac t t')
      then obtain B' where B':
          "B = ac: t  t'st#B'"
          "B'  set (tr (unlabel A) (unlabel D))"
        using Cons.prems(1) a by auto
      thus ?thesis using Cons.IH[OF B'(2) 1] a B'(1) Equality by auto
    next
      case (Insert t s)
      hence B: "B  set (tr (unlabel A) (List.insert (t,s) (unlabel D)))"
        using Cons.prems(1) a by auto

      let ?P = "λi. List.insert (t,s) (unlabel D) = unlabel (List.insert (i,t,s) D)"

      { obtain j where j: "?P j" "j = ia  (j,t,s)  set D"
          using labeled_list_insert_eq_ex_cases[of "(t,s)" D ia] by moura
        hence "j = ia" using Cons.prems(2) a Insert by (auto simp add: setopslsst_def)
        hence "?P ia" using j(1) by metis
      } hence j: "?P ia" by metis

      have 2: "(k1, p)  setopslsst A  set (List.insert (ia,t,s) D).
               (k2, q)  setopslsst A  set (List.insert (ia,t,s) D).
                 p = q  k1 = k2"
        using Cons.prems(2) a Insert by (auto simp add: setopslsst_def)

      show ?thesis using Cons.IH[OF _ 2] j(1) B Insert a by auto
    next
      case (Delete t s)
      define c where "c  (λ(i::'lbl strand_label) Di.
        map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di@
        map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) [dD. d  set Di])"

      define d where "d  (λDi.
        map (λd. check: (pair (t,s))  (pair d)st) Di@
        map (λd. []⟨∨≠: [(pair (t,s), pair d)]st) [dunlabel D. d  set Di])"

      obtain B' Di where B':
          "B = d Di@B'" "Di  set (subseqs (unlabel D))"
          "B'  set (tr (unlabel A) [dunlabel D. d  set Di])"
        using Cons.prems(1) a Delete unfolding d_def by auto

      obtain Di' where Di': "Di'  set (subseqs D)" "unlabel Di' = Di"
        using unlabel_subseqsD[OF B'(2)] by moura

      have 2: "(j, p)  setopslsst A  set [dD. d  set Di'].
               (k, q)  setopslsst A  set [dD. d  set Di'].
                 p = q  j = k"
        using 1 subseqs_subset[OF Di'(1)]
              filter_is_subset[of "λd. d  set Di'"]
        by blast

      have "set Di'  set D" by (rule subseqs_subset[OF Di'(1)])
      hence "(j, p)set D  set Di'. (k, q)set D  set Di'. p = q  j = k"
        using Cons.prems(2) by blast
      hence 3: "[dunlabel D. d  set Di] = unlabel [dD. d  set Di']"
        using Di'(2) unlabel_filter_eq[of D "set Di'"] unfolding unlabel_def by auto

      obtain C where C: "C  set (tr'pc A [dD. d  set Di'])" "B' = unlabel C"
        using 3 Cons.IH[OF _ 2] B'(3) by auto
      hence 4: "c ia Di'@C  set (tr'pc (a#A) D)" using Di'(1) a Delete unfolding c_def by auto

      have "unlabel (c ia Di') = d Di" using Di' 3 unfolding c_def d_def unlabel_def by auto
      hence 5: "B = unlabel (c ia Di'@C)" using B'(1) C(2) unlabel_append[of "c ia Di'" C] by simp

      show ?thesis using 4 5 by blast
    next
      case (InSet ac t s)
      then obtain B' d where B':
          "B = ac: (pair (t,s))  (pair d)st#B'"
          "B'  set (tr (unlabel A) (unlabel D))"
          "d  set (unlabel D)"
        using Cons.prems(1) a by auto
      thus ?thesis using Cons.IH[OF _ 1] a InSet unfolding unlabel_def by auto
    next
      case (NegChecks X F F')
      then obtain B' where B':
          "B = map (λG. X⟨∨≠: (F@G)st) (trpairs F' (unlabel D))@B'"
          "B'  set (tr (unlabel A) (unlabel D))"
        using Cons.prems(1) a by auto
      thus ?thesis using Cons.IH[OF _ 1] a NegChecks unfolding unlabel_def by auto
    qed
  qed simp
qed

subsubsection ‹Part 2›
private lemma tr_par_iff_tr'_par:
  assumes "(i,p)  setopslsst A  set D. (j,q)  setopslsst A  set D.
            (δ. Unifier δ (pair p) (pair q))  i = j"
    (is "?R3 A D")
  and "(l,t,s)  set D. (fv t  fv s)  bvarssst (unlabel A) = {}" (is "?R4 A D")
  and "fvsst (unlabel A)  bvarssst (unlabel A) = {}" (is "?R5 A D")
  shows "(B  set (trpc A D). M; unlabel Bd )  (C  set (tr'pc A D). M; unlabel Cd )"
    (is "?P  ?Q")
proof
  { fix B assume "B  set (trpc A D)" "M; unlabel Bd "
    hence ?Q using assms
    proof (induction A D arbitrary: B M rule: trpc.induct)
      case (1 D) thus ?case by simp
    next
      case (2 i t S D)
      note prems = "2.prems"
      note IH = "2.IH"

      obtain B' where B': "B = (i,send⟨tst)#B'" "B'  set (trpc S D)"
        using prems(1) by moura

      have 1: "M; unlabel B'd " using prems(2) B'(1) by simp
      have 4: "?R3 S D" using prems(3) by (auto simp add: setopslsst_def)
      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      have 7: "M  t  " using prems(2) B'(1) by simp

      obtain C where C: "C  set (tr'pc S D)" "M; unlabel Cd "
        using IH[OF B'(2) 1 4 5 6] by moura
      hence "((i,send⟨tst)#C)  set (tr'pc ((i,Send t)#S) D)" "M; unlabel ((i,send⟨tst)#C)d "
        using 7 by auto
      thus ?case by metis
    next
      case (3 i t S D)
      note prems = "3.prems"
      note IH = "3.IH"

      obtain B' where B': "B = (i,receive⟨tst)#B'" "B'  set (trpc S D)" using prems(1) by moura

      have 1: "insert (t  ) M; unlabel B'd  " using prems(2) B'(1) by simp
      have 4: "?R3 S D" using prems(3) by (auto simp add: setopslsst_def)
      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      obtain C where C: "C  set (tr'pc S D)" "insert (t  ) M; unlabel Cd "
        using IH[OF B'(2) 1 4 5 6] by moura
      hence "((i,receive⟨tst)#C)  set (tr'pc ((i,receive⟨t)#S) D)"
            "insert (t  ) M; unlabel ((i,receive⟨tst)#C)d "
        by auto
      thus ?case by auto
    next
      case (4 i ac t t' S D)
      note prems = "4.prems"
      note IH = "4.IH"

      obtain B' where B': "B = (i,ac: t  t'st)#B'" "B'  set (trpc S D)"
        using prems(1) by moura

      have 1: "M; unlabel B'd  " using prems(2) B'(1) by simp
      have 4: "?R3 S D" using prems(3) by (auto simp add: setopslsst_def)
      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      have 7: "t   = t'  " using prems(2) B'(1) by simp

      obtain C where C: "C  set (tr'pc S D)" "M; unlabel Cd "
        using IH[OF B'(2) 1 4 5 6] by moura
      hence "((i,ac: t  t'st)#C)  set (tr'pc ((i,Equality ac t t')#S) D)"
            "M; unlabel ((i,ac: t  t'st)#C)d "
        using 7 by auto
      thus ?case by metis
    next
      case (5 i t s S D)
      note prems = "5.prems"
      note IH = "5.IH"

      have B: "B  set (trpc S (List.insert (i,t,s) D))" using prems(1) by simp

      have 1: "M; unlabel Bd  " using prems(2) B(1) by simp
      have 4: "?R3 S (List.insert (i,t,s) D)" using prems(3) by (auto simp add: setopslsst_def)
      have 5: "?R4 S (List.insert (i,t,s) D)" using prems(4,5) by force
      have 6: "?R5 S D" using prems(5) by force

      show ?case using IH[OF B(1) 1 4 5 6] by simp
    next
      case (6 i t s S D)
      note prems = "6.prems"
      note IH = "6.IH"

      let ?cl1 = "λDi. map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di"
      let ?cu1 = "λDi. map (λd. check: (pair (t,s))  (pair (snd d))st) Di"
      let ?cl2 = "λDi. map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) [ddbproj i D. dset Di]"
      let ?cu2 = "λDi. map (λd. []⟨∨≠: [(pair (t,s), pair (snd d))]st) [ddbproj i D. dset Di]"

      let ?dl1 = "λDi. map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di"
      let ?du1 = "λDi. map (λd. check: (pair (t,s))  (pair (snd d))st) Di"
      let ?dl2 = "λDi. map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) [dD. dset Di]"
      let ?du2 = "λDi. map (λd. []⟨∨≠: [(pair (t,s), pair (snd d))]st) [dD. dset Di]"

      define c where c: "c = (λDi. ?cl1 Di@?cl2 Di)"
      define d where d: "d = (λDi. ?dl1 Di@?dl2 Di)"

      obtain B' Di where B':
          "Di  set (subseqs (dbproj i D))" "B = c Di@B'" "B'  set (trpc S [dD. d  set Di])"
        using prems(1) c by moura

      have 0: "ikst (unlabel (c Di)) = {}" "ikst (unlabel (d Di)) = {}"
              "unlabel (?cl1 Di) = ?cu1 Di" "unlabel (?cl2 Di) = ?cu2 Di"
              "unlabel (?dl1 Di) = ?du1 Di" "unlabel (?dl2 Di) = ?du2 Di"
        unfolding c d unlabel_def by force+

      have 1: "M; unlabel B'd  " using prems(2) B'(2) 0(1) unfolding unlabel_def by auto

      { fix j p k q
        assume "(j, p)  setopslsst S  set [dD. d  set Di]"
               "(k, q)  setopslsst S  set [dD. d  set Di]"
        hence "(j, p)  setopslsst ((i, delete⟨t,s)#S)  set D"
              "(k, q)  setopslsst ((i, delete⟨t,s)#S)  set D"
          using dbproj_subseq_subset[OF B'(1)] by (auto simp add: setopslsst_def)
        hence "(δ. Unifier δ (pair p) (pair q))  j = k" using prems(3) by blast
      } hence 4: "?R3 S [dD. d  set Di]" by blast

      have 5: "?R4 S (filter (λd. d  set Di) D)" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      obtain C where C: "C  set (tr'pc S [dD . d  set Di])" "M; unlabel Cd "
        using IH[OF B'(1,3) 1 4 5 6] by moura

      have 7: "M; unlabel (c Di)d " "M; unlabel B'd "
        using prems(2) B'(2) 0(1) strand_sem_split(3,4)[of M "unlabel (c Di)" "unlabel B'"]
        unfolding c unlabel_def by auto

      have "M; unlabel (?cl2 Di)d " using 7(1) 0(1) unfolding c unlabel_def by auto
      hence "M; ?cu2 Did " by (metis 0(4))
      moreover {
        fix j p k q
        assume "(j, p)  {(i, t, s)}  set D  set Di"
               "(k, q)  {(i, t, s)}  set D  set Di"
        hence "(j, p)  setopslsst ((i, delete⟨t,s)#S)  set D"
              "(k, q)  setopslsst ((i, delete⟨t,s)#S)  set D"
          using dbproj_subseq_subset[OF B'(1)] by (auto simp add: setopslsst_def)
        hence "(δ. Unifier δ (pair p) (pair q))  j = k" using prems(3) by blast
      } hence "(j, p)  {(i, t, s)}  set D  set Di.
               (k, q)  {(i, t, s)}  set D  set Di.
                (δ. Unifier δ (pair p) (pair q))  j = k"
        by blast
      ultimately have "M; ?du2 Did " using labeled_sat_ineq_lift by simp
      hence "M; unlabel (?dl2 Di)d " by (metis 0(6))
      moreover have "M; unlabel (?cl1 Di)d " using 7(1) unfolding c unlabel_def by auto
      hence "M; unlabel (?dl1 Di)d " by (metis 0(3,5))
      ultimately have "M; unlabel (d Di)d " using 0(2) unfolding c d unlabel_def by force
      hence 8: "M; unlabel (d Di@C)d " using 0(2) C(2) unfolding unlabel_def by auto

      have 9: "d Di@C  set (tr'pc ((i,delete⟨t,s)#S) D)"
        using C(1) dbproj_subseq_in_subseqs[OF B'(1)]
        unfolding d unlabel_def by auto

      show ?case by (metis 8 9)
    next
      case (7 i ac t s S D)
      note prems = "7.prems"
      note IH = "7.IH"

      obtain B' d where B':
          "B = (i,ac: (pair (t,s))  (pair (snd d))st)#B'"
          "B'  set (trpc S D)" "d  set (dbproj i D)"
        using prems(1) by moura

      have 1: "M; unlabel B'd  " using prems(2) B'(1) by simp

      { fix j p k q
        assume "(j,p)  setopslsst S  set D"
               "(k,q)  setopslsst S  set D"
        hence "(j,p)  setopslsst ((i, InSet ac t s)#S)  set D"
              "(k,q)  setopslsst ((i, InSet ac t s)#S)  set D"
          by (auto simp add: setopslsst_def)
        hence "(δ. Unifier δ (pair p) (pair q))  j = k" using prems(3) by blast
      } hence 4: "?R3 S D" by blast

      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force
      have 7: "pair (t,s)   = pair (snd d)  " using prems(2) B'(1) by simp

      obtain C where C: "C  set (tr'pc S D)" "M; unlabel Cd "
        using IH[OF B'(2) 1 4 5 6] by moura
      hence "((i,ac: (pair (t,s))  (pair (snd d))st)#C)  set (tr'pc ((i,InSet ac t s)#S) D)"
            "M; unlabel ((i,ac: (pair (t,s))  (pair (snd d))st)#C)d "
        using 7 B'(3) by auto
      thus ?case by metis
    next
      case (8 i X F F' S D)
      note prems = "8.prems"
      note IH = "8.IH"

      let ?cl = "map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd (dbproj i D)))"
      let ?cu = "map (λG. X⟨∨≠: (F@G)st) (trpairs F' (map snd (dbproj i D)))"

      let ?dl = "map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd D))"
      let ?du = "map (λG. X⟨∨≠: (F@G)st) (trpairs F' (map snd D))"

      define c where c: "c = ?cl"
      define d where d: "d = ?dl"

      obtain B' where B': "B = c@B'" "B'  set (trpc S D)" using prems(1) c by moura

      have 0: "ikst (unlabel c) = {}" "ikst (unlabel d) = {}"
              "unlabel ?cl = ?cu" "unlabel ?dl = ?du"
        unfolding c d unlabel_def by force+

      have "ikst (unlabel c) = {}" unfolding c unlabel_def by force
      hence 1: "M; unlabel B'd  " using prems(2) B'(1) unfolding unlabel_def by auto

      have "setopslsst S  setopslsst ((i, NegChecks X F F')#S)" by (auto simp add: setopslsst_def)
      hence 4: "?R3 S D" using prems(3) by blast

      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      obtain C where C: "C  set (tr'pc S D)" "M; unlabel Cd "
        using IH[OF B'(2) 1 4 5 6] by moura

      have 7: "M; unlabel cd " "M; unlabel B'd "
        using prems(2) B'(1) 0(1) strand_sem_split(3,4)[of M "unlabel c" "unlabel B'"]
        unfolding c unlabel_def by auto

      have 8: "d@C  set (tr'pc ((i,NegChecks X F F')#S) D)"
        using C(1) unfolding d unlabel_def by auto

      have "M; unlabel ?cld " using 7(1) unfolding c unlabel_def by auto
      hence "M; ?cud " by (metis 0(3))
      moreover {
        fix j p k q
        assume "(j, p)  ((λ(t,s). (i,t,s)) ` set F')  set D"
               "(k, q)  ((λ(t,s). (i,t,s)) ` set F')  set D"
        hence "(j, p)  setopslsst ((i, NegChecks X F F')#S)  set D"
              "(k, q)  setopslsst ((i, NegChecks X F F')#S)  set D"
          by (auto simp add: setopslsst_def)
        hence "(δ. Unifier δ (pair p) (pair q))  j = k" using prems(3) by blast
      } hence "(j, p)  ((λ(t,s). (i,t,s)) ` set F')  set D.
               (k, q)  ((λ(t,s). (i,t,s)) ` set F')  set D.
                (δ. Unifier δ (pair p) (pair q))  j = k"
        by blast
      moreover have "fvpairs (map snd D)  set X = {}"
        using prems(4) by fastforce
      ultimately have "M; ?dud " using labeled_sat_ineq_dbproj_sem_equiv[of i] by simp
      hence "M; unlabel ?dld " by (metis 0(4))
      hence "M; unlabel dd " using 0(2) unfolding c d unlabel_def by force
      hence 9: "M; unlabel (d@C)d " using 0(2) C(2) unfolding unlabel_def by auto

      show ?case by (metis 8 9)
    qed
  } thus "?P  ?Q" by metis

  { fix C assume "C  set (tr'pc A D)" "M; unlabel Cd "
    hence ?P using assms
    proof (induction A D arbitrary: C M rule: tr'pc.induct)
      case (1 D) thus ?case by simp
    next
      case (2 i t S D)
      note prems = "2.prems"
      note IH = "2.IH"

      obtain C' where C': "C = (i,send⟨tst)#C'" "C'  set (tr'pc S D)"
        using prems(1) by moura

      have 1: "M; unlabel C'd  " using prems(2) C'(1) by simp
      have 4: "?R3 S D" using prems(3) by (auto simp add: setopslsst_def)
      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      have 7: "M  t  " using prems(2) C'(1) by simp

      obtain B where B: "B  set (trpc S D)" "M; unlabel Bd "
        using IH[OF C'(2) 1 4 5 6] by moura
      hence "((i,send⟨tst)#B)  set (trpc ((i,Send t)#S) D)"
            "M; unlabel ((i,send⟨tst)#B)d "
        using 7 by auto
      thus ?case by metis
    next
      case (3 i t S D)
      note prems = "3.prems"
      note IH = "3.IH"

      obtain C' where C': "C = (i,receive⟨tst)#C'" "C'  set (tr'pc S D)"
        using prems(1) by moura

      have 1: "insert (t  ) M; unlabel C'd  " using prems(2) C'(1) by simp
      have 4: "?R3 S D" using prems(3) by (auto simp add: setopslsst_def)
      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      obtain B where B: "B  set (trpc S D)" "insert (t  ) M; unlabel Bd "
        using IH[OF C'(2) 1 4 5 6] by moura
      hence "((i,receive⟨tst)#B)  set (trpc ((i,receive⟨t)#S) D)"
            "insert (t  ) M; unlabel ((i,receive⟨tst)#B)d "
        by auto
      thus ?case by auto
    next
      case (4 i ac t t' S D)
      note prems = "4.prems"
      note IH = "4.IH"

      obtain C' where C': "C = (i,ac: t  t'st)#C'" "C'  set (tr'pc S D)"
        using prems(1) by moura

      have 1: "M; unlabel C'd  " using prems(2) C'(1) by simp
      have 4: "?R3 S D" using prems(3) by (auto simp add: setopslsst_def)
      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      have 7: "t   = t'  " using prems(2) C'(1) by simp

      obtain B where B: "B  set (trpc S D)" "M; unlabel Bd "
        using IH[OF C'(2) 1 4 5 6] by moura
      hence "((i,ac: t  t'st)#B)  set (trpc ((i,Equality ac t t')#S) D)"
            "M; unlabel ((i,ac: t  t'st)#B)d "
        using 7 by auto
      thus ?case by metis
    next
      case (5 i t s S D)
      note prems = "5.prems"
      note IH = "5.IH"

      have C: "C  set (tr'pc S (List.insert (i,t,s) D))" using prems(1) by simp

      have 1: "M; unlabel Cd  " using prems(2) C(1) by simp
      have 4: "?R3 S (List.insert (i,t,s) D)" using prems(3) by (auto simp add: setopslsst_def)
      have 5: "?R4 S (List.insert (i,t,s) D)" using prems(4,5) by force
      have 6: "?R5 S (List.insert (i,t,s) D)" using prems(5) by force

      show ?case using IH[OF C(1) 1 4 5 6] by simp
    next
      case (6 i t s S D)
      note prems = "6.prems"
      note IH = "6.IH"

      let ?dl1 = "λDi. map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di"
      let ?du1 = "λDi. map (λd. check: (pair (t,s))  (pair (snd d))st) Di"
      let ?dl2 = "λDi. map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) [ddbproj i D. dset Di]"
      let ?du2 = "λDi. map (λd. []⟨∨≠: [(pair (t,s), pair (snd d))]st) [ddbproj i D. dset Di]"

      let ?cl1 = "λDi. map (λd. (i,check: (pair (t,s))  (pair (snd d))st)) Di"
      let ?cu1 = "λDi. map (λd. check: (pair (t,s))  (pair (snd d))st) Di"
      let ?cl2 = "λDi. map (λd. (i,[]⟨∨≠: [(pair (t,s), pair (snd d))]st)) [dD. dset Di]"
      let ?cu2 = "λDi. map (λd. []⟨∨≠: [(pair (t,s), pair (snd d))]st) [dD. dset Di]"

      define c where c: "c = (λDi. ?cl1 Di@?cl2 Di)"
      define d where d: "d = (λDi. ?dl1 Di@?dl2 Di)"

      obtain C' Di where C':
          "Di  set (subseqs D)" "C = c Di@C'" "C'  set (tr'pc S [dD. d  set Di])"
        using prems(1) c by moura

      have 0: "ikst (unlabel (c Di)) = {}" "ikst (unlabel (d Di)) = {}"
              "unlabel (?cl1 Di) = ?cu1 Di" "unlabel (?cl2 Di) = ?cu2 Di"
              "unlabel (?dl1 Di) = ?du1 Di" "unlabel (?dl2 Di) = ?du2 Di"
        unfolding c d unlabel_def by force+

      have 1: "M; unlabel C'd  " using prems(2) C'(2) 0(1) unfolding unlabel_def by auto

      { fix j p k q
        assume "(j, p)  setopslsst S  set [dD. d  set Di]"
               "(k, q)  setopslsst S  set [dD. d  set Di]"
        hence "(j, p)  setopslsst ((i, delete⟨t,s)#S)  set D"
              "(k, q)  setopslsst ((i, delete⟨t,s)#S)  set D"
          by (auto simp add: setopslsst_def)
        hence "(δ. Unifier δ (pair p) (pair q))  j = k" using prems(3) by blast
      } hence 4: "?R3 S [dD. d  set Di]" by blast

      have 5: "?R4 S (filter (λd. d  set Di) D)" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      obtain B where B: "B  set (trpc S [dD. d  set Di])" "M; unlabel Bd "
        using IH[OF C'(1,3) 1 4 5 6] by moura

      have 7: "M; unlabel (c Di)d " "M; unlabel C'd "
        using prems(2) C'(2) 0(1) strand_sem_split(3,4)[of M "unlabel (c Di)" "unlabel C'"]
        unfolding c unlabel_def by auto

      { fix j p k q
        assume "(j, p)  {(i, t, s)}  set D"
               "(k, q)  {(i, t, s)}  set D"
        hence "(j, p)  setopslsst ((i, delete⟨t,s)#S)  set D"
              "(k, q)  setopslsst ((i, delete⟨t,s)#S)  set D"
          by (auto simp add: setopslsst_def)
        hence "(δ. Unifier δ (pair p) (pair q))  j = k" using prems(3) by blast
      } hence "(j, p)  {(i, t, s)}  set D.
               (k, q)  {(i, t, s)}  set D.
                (δ. Unifier δ (pair p) (pair q))  j = k"
        by blast
      moreover have "M; unlabel (?cl1 Di)d " using 7(1) unfolding c unlabel_append by auto
      hence "M; ?cu1 Did " by (metis 0(3))
      ultimately have *: "Di  set (subseqs (dbproj i D))"
        using labeled_sat_eqs_subseqs[OF C'(1)] by simp
      hence 8: "d Di@B  set (trpc ((i,delete⟨t,s)#S) D)"
        using B(1) unfolding d unlabel_def by auto

      have "M; unlabel (?cl2 Di)d " using 7(1) 0(1) unfolding c unlabel_def by auto
      hence "M; ?cu2 Did " by (metis 0(4))
      hence "M; ?du2 Did " by (metis labeled_sat_ineq_dbproj)
      hence "M; unlabel (?dl2 Di)d " by (metis 0(6))
      moreover have "M; unlabel (?cl1 Di)d " using 7(1) unfolding c unlabel_def by auto
      hence "M; unlabel (?dl1 Di)d " by (metis 0(3,5))
      ultimately have "M; unlabel (d Di)d " using 0(2) unfolding c d unlabel_def by force
      hence 9: "M; unlabel (d Di@B)d " using 0(2) B(2) unfolding unlabel_def by auto

      show ?case by (metis 8 9)
    next
      case (7 i ac t s S D)
      note prems = "7.prems"
      note IH = "7.IH"

      obtain C' d where C':
          "C = (i,ac: (pair (t,s))  (pair (snd d))st)#C'"
          "C'  set (tr'pc S D)" "d  set D"
        using prems(1) by moura

      have 1: "M; unlabel C'd  " using prems(2) C'(1) by simp

      { fix j p k q
        assume "(j,p)  setopslsst S  set D"
               "(k,q)  setopslsst S  set D"
        hence "(j,p)  setopslsst ((i, InSet ac t s)#S)  set D"
              "(k,q)  setopslsst ((i, InSet ac t s)#S)  set D"
          by (auto simp add: setopslsst_def)
        hence "(δ. Unifier δ (pair p) (pair q))  j = k" using prems(3) by blast
      } hence 4: "?R3 S D" by blast

      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      obtain B where B: "B  set (trpc S D)" "M; unlabel Bd "
        using IH[OF C'(2) 1 4 5 6] by moura

      have 7: "pair (t,s)   = pair (snd d)  " using prems(2) C'(1) by simp

      have "(i,t,s)  setopslsst ((i, InSet ac t s)#S)  set D"
           "(fst d, snd d)  setopslsst ((i, InSet ac t s)#S)  set D"
        using C'(3) by (auto simp add: setopslsst_def)
      hence "δ. Unifier δ (pair (t,s)) (pair (snd d))  i = fst d"
        using prems(3) by blast
      hence "fst d = i" using 7 by auto
      hence 8: "d  set (dbproj i D)" using C'(3) by auto

      have 9: "((i,ac: (pair (t,s))  (pair (snd d))st)#B)  set (trpc ((i,InSet ac t s)#S) D)"
        using B 8 by auto
      have 10: "M; unlabel ((i,ac: (pair (t,s))  (pair (snd d))st)#B)d "
        using B 7 8 by auto

      show ?case by (metis 9 10)
    next
      case (8 i X F F' S D)
      note prems = "8.prems"
      note IH = "8.IH"

      let ?dl = "map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd (dbproj i D)))"
      let ?du = "map (λG. X⟨∨≠: (F@G)st) (trpairs F' (map snd (dbproj i D)))"

      let ?cl = "map (λG. (i,X⟨∨≠: (F@G)st)) (trpairs F' (map snd D))"
      let ?cu = "map (λG. X⟨∨≠: (F@G)st) (trpairs F' (map snd D))"

      define c where c: "c = ?cl"
      define d where d: "d = ?dl"

      obtain C' where C': "C = c@C'" "C'  set (tr'pc S D)" using prems(1) c by moura

      have 0: "ikst (unlabel c) = {}" "ikst (unlabel d) = {}"
              "unlabel ?cl = ?cu" "unlabel ?dl = ?du"
        unfolding c d unlabel_def by force+

      have "ikst (unlabel c) = {}" unfolding c unlabel_def by force
      hence 1: "M; unlabel C'd  " using prems(2) C'(1) unfolding unlabel_def by auto

      have "setopslsst S  setopslsst ((i, NegChecks X F F')#S)" by (auto simp add: setopslsst_def)
      hence 4: "?R3 S D" using prems(3) by blast

      have 5: "?R4 S D" using prems(4) by force
      have 6: "?R5 S D" using prems(5) by force

      obtain B where B: "B  set (trpc S D)" "M; unlabel Bd "
        using IH[OF C'(2) 1 4 5 6] by moura

      have 7: "M; unlabel cd " "M; unlabel C'd "
        using prems(2) C'(1) 0(1) strand_sem_split(3,4)[of M "unlabel c" "unlabel C'"]
        unfolding c unlabel_def by auto

      have 8: "d@B  set (trpc ((i,NegChecks X F F')#S) D)"
        using B(1) unfolding d unlabel_def by auto

      have "M; unlabel ?cld " using 7(1) unfolding c unlabel_def by auto
      hence "M; ?cud " by (metis 0(3))
      moreover {
        fix j p k q
        assume "(j, p)  ((λ(t,s). (i,t,s)) ` set F')  set D"
               "(k, q)  ((λ(t,s). (i,t,s)) ` set F')  set D"
        hence "(j, p)  setopslsst ((i, NegChecks X F F')#S)  set D"
              "(k, q)  setopslsst ((i, NegChecks X F F')#S)  set D"
          by (auto simp add: setopslsst_def)
        hence "(δ. Unifier δ (pair p) (pair q))  j = k" using prems(3) by blast
      } hence "(j, p)  ((λ(t,s). (i,t,s)) ` set F')  set D.
               (k, q)  ((λ(t,s). (i,t,s)) ` set F')  set D.
                (δ. Unifier δ (pair p) (pair q))  j = k"
        by blast
      moreover have "fvpairs (map snd D)  set X = {}"
        using prems(4) by fastforce
      ultimately have "M; ?dud " using labeled_sat_ineq_dbproj_sem_equiv[of i] by simp
      hence "M; unlabel ?dld " by (metis 0(4))
      hence "M; unlabel dd " using 0(2) unfolding c d unlabel_def by force
      hence 9: "M; unlabel (d@B)d " using 0(2) B(2) unfolding unlabel_def by auto

      show ?case by (metis 8 9)
    qed
  } thus "?Q  ?P" by metis
qed


subsubsection ‹Part 3›
private lemma tr'_par_sem_equiv:
  assumes "(l,t,s)  set D. (fv t  fv s)  bvarssst (unlabel A) = {}"
  and "fvsst (unlabel A)  bvarssst (unlabel A) = {}" "ground M"
  and "(i,p)  setopslsst A  set D. (j,q)  setopslsst A  set D.
        (δ. Unifier δ (pair p) (pair q))  i = j" (is "?R A D")
  and: "interpretationsubst "
  shows "M; set (unlabel D) pset ; unlabel As   (B  set (tr'pc A D). M; unlabel Bd )"
        (is "?P  ?Q")
proof -
  have 1: "(t,s)  set (unlabel D). (fv t  fv s)  bvarssst (unlabel A) = {}"
    using assms(1) unfolding unlabel_def by force

  have 2: "(i,p)  setopslsst A  set D. (j,q)  setopslsst A  set D. p = q  i = j"
    using assms(4) subst_apply_term_empty by blast

  show ?thesis by (metis tr_sem_equiv'[OF 1 assms(2,3)] tr'_par_iff_unlabel_tr[OF 2])
qed


subsubsection ‹Part 4›
lemma tr_par_sem_equiv:
  assumes "(l,t,s)  set D. (fv t  fv s)  bvarssst (unlabel A) = {}"
  and "fvsst (unlabel A)  bvarssst (unlabel A) = {}" "ground M"
  and "(i,p)  setopslsst A  set D. (j,q)  setopslsst A  set D.
        (δ. Unifier δ (pair p) (pair q))  i = j"
  and: "interpretationsubst "
  shows "M; set (unlabel D) pset ; unlabel As   (B  set (trpc A D). M; unlabel Bd )"
  (is "?P  ?Q")
using tr_par_iff_tr'_par[OF assms(4,1,2), of M ] tr'_par_sem_equiv[OF assms] by metis

end


subsection ‹Theorem: The Stateful Compositionality Result, on the Constraint Level›
theorem par_comp_constr_stateful:
  assumes 𝒜: "par_complsst 𝒜 Sec" "typing_condsst (unlabel 𝒜)"
  and: " s unlabel 𝒜" "interpretationsubst "
  shows "τ. interpretationsubst τ  wtsubst τ  wftrms (subst_range τ)  (τ s unlabel 𝒜) 
              ((n. τ s proj_unl n 𝒜)  (𝒜'. prefix 𝒜' 𝒜  (𝒜' leaks Sec under τ)))"
proof -
  let ?P = "λn A D.
       (i, p)  setopslsst (proj n A)  set D.
       (j, q)  setopslsst (proj n A)  set D.
          (δ. Unifier δ (pair p) (pair q))  i = j"

  have 1: "(l, t, t')set []. (fv t  fv t')  bvarssst (unlabel 𝒜) = {}"
          "fvsst (unlabel 𝒜)  bvarssst (unlabel 𝒜) = {}" "ground {}"
    using 𝒜(2) unfolding typing_condsst_def by simp_all

  have 2: "n. (l, t, t')set []. (fv t  fv t')  bvarssst (proj_unl n 𝒜) = {}"
          "n. fvsst (proj_unl n 𝒜)  bvarssst (proj_unl n 𝒜) = {}"
    using 1(1,2) sst_vars_proj_subset[of _ 𝒜] by fast+

  have 3: "n. par_complsst (proj n 𝒜) Sec"
    using par_complsst_proj[OF 𝒜(1)] by metis

  have 4:
      "{}; set (unlabel []) pset ℐ'; unlabel 𝒜s ℐ' 
        (Bset (trpc 𝒜 []). {}; unlabel Bd ℐ')"
    when ℐ': "interpretationsubst ℐ'" for ℐ'
    using tr_par_sem_equiv[OF 1 _ ℐ'] 𝒜(1)
    unfolding par_complsst_def constr_sem_d_def by auto

  obtain 𝒜' where 𝒜': "𝒜'  set (trpc 𝒜 [])" "  unlabel 𝒜'"
    using 4[OF(2)](1) unfolding constr_sem_d_def by moura

  obtain τ whereτ:
      "interpretationsubst τ" "wtsubst τ" "wftrms (subst_range τ)" "τ  unlabel 𝒜'"
      "(n. (τ  proj_unl n 𝒜'))  (𝒜''. prefix 𝒜'' 𝒜'  (strand_leakslst 𝒜'' Sec τ))"
    using par_comp_constr[OF tr_par_preserves_par_comp[OF 𝒜(1) 𝒜'(1)]
                             tr_par_preserves_typing_cond[OF 𝒜 𝒜'(1)]
                             𝒜'(2)(2)]
    by moura

  haveτ': "τ s unlabel 𝒜" using 4[OFτ(1)] 𝒜'(1)τ(4) unfolding constr_sem_d_def by auto

  show ?thesis
  proof (cases "n. (τ  proj_unl n 𝒜')")
    case True
    { fix n assume "τ  proj_unl n 𝒜'"
      hence "{}; {}; unlabel (proj n 𝒜)s τ"
        using tr_par_proj[OF 𝒜'(1), of n]
              tr_par_sem_equiv[OF 2(1,2) 1(3) _ ℐτ(1), of n] 3(1)
        unfolding par_complsst_def proj_def constr_sem_d_def by force
    } thus ?thesis using True ℐτ(1,2,3)τ' by metis
  next
    case False
    then obtain 𝒜''::"('fun,'var,'lbl) labeled_strand" where 𝒜'':
        "prefix 𝒜'' 𝒜'" "strand_leakslst 𝒜'' Sec τ"
      usingτ by blast
    moreover {
      fix t l assume *: "{}; unlabel (proj l 𝒜'')@[send⟨tst]d τ"
      have "τ  unlabel (proj l 𝒜'')" "ikst (unlabel (proj l 𝒜'')) set τ  t  τ"
        using strand_sem_split(3,4)[OF *] unfolding constr_sem_d_def by auto
    } ultimately have "t  Sec - declassifiedlst 𝒜'' τ. l.
            (τ  unlabel (proj l 𝒜''))  ikst (unlabel (proj l 𝒜'')) set τ  t  τ"
      unfolding strand_leakslst_def constr_sem_d_def by metis
    then obtain s m where sm:
        "s  Sec - declassifiedlst 𝒜'' τ"
        "τ  unlabel (proj m 𝒜'')"
        "ikst (unlabel (proj m 𝒜'')) set τ  s  τ"
      by moura

    ― ‹
      We now need to show that there is some prefix B› of 𝒜''› that also leaks
      and where B ∈ set (tr C D)› for some prefix C› of 𝒜›
    obtain B::"('fun,'var,'lbl) labeled_strand"
        and C::"('fun,'var,'lbl) labeled_stateful_strand"
      where BC:
        "prefix B 𝒜'" "prefix C 𝒜" "B  set (trpc C [])"
        "ikst (unlabel (proj m B)) set τ  s  τ"
        "prefix B 𝒜''"
      using tr_leaking_prefix_exists[OF 𝒜'(1) 𝒜''(1) sm(3)] prefix_order.order_trans[OF _ 𝒜''(1)]
      by auto
    have "{}; unlabel (proj m B)d τ"
      using sm(2) BC(5) unfolding prefix_def unlabel_def proj_def constr_sem_d_def by auto
    hence BC': "τ  proj_unl m B@[send⟨sst]"
      using BC(4) unfolding constr_sem_d_def by auto
    have BC'': "s  Sec - declassifiedlst B τ"
      using BC(5) sm(1) unfolding prefix_def declassifiedlst_def by auto
    have 5: "par_complsst (proj n C) Sec" for n
      using 𝒜(1) BC(2) par_complsst_split(1)[THEN par_complsst_proj]
      unfolding prefix_def by auto
    have "fvsst (unlabel 𝒜)  bvarssst (unlabel 𝒜) = {}"
         "fvsst (unlabel C)  fvsst (unlabel 𝒜)"
         "bvarssst (unlabel C)  bvarssst (unlabel 𝒜)"
      using 𝒜(2) BC(2) sst_vars_append_subset(1,2)[of "unlabel C"]
      unfolding typing_condsst_def prefix_def unlabel_def by auto
    hence "fvsst (proj_unl n C)  bvarssst (proj_unl n C) = {}" for n
      using sst_vars_proj_subset[of _ C] sst_vars_proj_subset[of _ 𝒜]
      by blast
    hence 6:
        "(l, t, t')set []. (fv t  fv t')  bvarssst (proj_unl n C) = {}"
        "fvsst (proj_unl n C)  bvarssst (proj_unl n C) = {}"
        "ground {}"
      for n
      using 2 by auto
    have 7: "?P n C []" for n using 5 unfolding par_complsst_def by simp
    have "s  τ = s" usingτ(1) BC'' 𝒜(1) unfolding par_complsst_def by auto
    hence "n. (τ s proj_unl n C)  iksst (proj_unl n C) set τ  s  τ"
      using tr_par_proj[OF BC(3), of m] BC'(1)
            tr_par_sem_equiv[OF 6 7 ℐτ(1), of m]
            tr_par_deduct_iff[OF tr_par_proj(1)[OF BC(3)], of τ m s]
      unfolding proj_def constr_sem_d_def by auto
    hence "n. τ s (proj_unl n C@[Send s])" using strand_sem_append_stateful by simp
    moreover have "s  Sec - declassifiedlsst C τ" by (metis tr_par_declassified_eq BC(3) BC'')
    ultimately show ?thesis usingτ(1,2,3)τ' BC(2) unfolding strand_leakslsst_def by metis
  qed
qed


subsection ‹Theorem: The Stateful Compositionality Result, on the Protocol Level›
abbreviation wflsst where
  "wflsst V 𝒜  wf'sst V (unlabel 𝒜)"

text ‹
  We state our result on the level of protocol traces (i.e., the constraints reachable in a
  symbolic execution of the actual protocol). Hence, we do not need to convert protocol strands
  to intruder constraints in the following well-formedness definitions.
›
definition wflssts::"('fun,'var,'lbl) labeled_stateful_strand set  bool" where
  "wflssts 𝒮  (𝒜  𝒮. wflsst {} 𝒜)  (𝒜  𝒮. 𝒜'  𝒮. fvlsst 𝒜  bvarslsst 𝒜' = {})"

definition wflssts'::
  "('fun,'var,'lbl) labeled_stateful_strand set  ('fun,'var,'lbl) labeled_stateful_strand  bool"
where
  "wflssts' 𝒮 𝒜  (𝒜'  𝒮. wf'sst (wfrestrictedvarslsst 𝒜) (unlabel 𝒜')) 
                 (𝒜'  𝒮. 𝒜''  𝒮. fvlsst 𝒜'  bvarslsst 𝒜'' = {}) 
                 (𝒜'  𝒮. fvlsst 𝒜'  bvarslsst 𝒜 = {}) 
                 (𝒜'  𝒮. fvlsst 𝒜  bvarslsst 𝒜' = {})"

definition typing_cond_prot_stateful where
  "typing_cond_prot_stateful 𝒫 
    wflssts 𝒫 
    tfrset ((trmslsst ` 𝒫)  pair ` (setopssst ` unlabel ` 𝒫)) 
    wftrms ((trmslsst ` 𝒫)) 
    (S  𝒫. list_all tfrsstp (unlabel S))"

definition par_comp_prot_stateful where
  "par_comp_prot_stateful 𝒫 Sec 
    (l1 l2. l1  l2 
      GSMP_disjoint (𝒜  𝒫. trmssst (proj_unl l1 𝒜)  pair ` setopssst (proj_unl l1 𝒜))
                    (𝒜  𝒫. trmssst (proj_unl l2 𝒜)  pair ` setopssst (proj_unl l2 𝒜)) Sec) 
    ground Sec  (s  Sec. s'  subterms s. {} c s'  s'  Sec) 
    ((i,p)  𝒜  𝒫. setopslsst 𝒜. (j,q)  𝒜  𝒫. setopslsst 𝒜.
      (δ. Unifier δ (pair p) (pair q))  i = j) 
    typing_cond_prot_stateful 𝒫"

definition component_secure_prot_stateful where
  "component_secure_prot_stateful n P Sec attack 
    (𝒜  P. suffix [(ln n, Send (Fun attack []))] 𝒜 
     (τ. (interpretationsubst τ  wtsubst τ  wftrms (subst_range τ)) 
            ¬(τ s (proj_unl n 𝒜)) 
            (𝒜'. prefix 𝒜' 𝒜 
                    (t  Sec-declassifiedlsst 𝒜' τ. ¬(τ s (proj_unl n 𝒜'@[Send t]))))))"

definition component_leaks_stateful where
  "component_leaks_stateful n 𝒜 Sec 
    (𝒜' τ. interpretationsubst τ  wtsubst τ  wftrms (subst_range τ)  prefix 𝒜' 𝒜 
             (t  Sec - declassifiedlsst 𝒜' τ. (τ s (proj_unl n 𝒜'@[Send t]))))"

definition unsat_stateful where
  "unsat_stateful 𝒜  (. interpretationsubst   ¬( s unlabel 𝒜))"

lemma wflssts_eqs_wflssts'[simp]: "wflssts S = wflssts' S []"
unfolding wflssts_def wflssts'_def unlabel_def wfrestrictedvarssst_def by simp

lemma par_comp_prot_impl_par_comp_stateful:
  assumes "par_comp_prot_stateful 𝒫 Sec" "𝒜  𝒫"
  shows "par_complsst 𝒜 Sec"
proof -
  have *:
      "l1 l2. l1  l2 
          GSMP_disjoint (𝒜  𝒫. trmssst (proj_unl l1 𝒜)  pair ` setopssst (proj_unl l1 𝒜))
                        (𝒜  𝒫. trmssst (proj_unl l2 𝒜)  pair ` setopssst (proj_unl l2 𝒜)) Sec"
    using assms(1) unfolding par_comp_prot_stateful_def by argo
  { fix l1 l2::'lbl assume **: "l1  l2"
    hence ***:
        "GSMP_disjoint (𝒜  𝒫. trmssst (proj_unl l1 𝒜)  pair ` setopssst (proj_unl l1 𝒜))
                       (𝒜  𝒫. trmssst (proj_unl l2 𝒜)  pair ` setopssst (proj_unl l2 𝒜)) Sec"
      using * by auto
    have "GSMP_disjoint (trmssst (proj_unl l1 𝒜)  pair ` setopssst (proj_unl l1 𝒜))
                        (trmssst (proj_unl l2 𝒜)  pair ` setopssst (proj_unl l2 𝒜)) Sec"
      using GSMP_disjoint_subset[OF ***] assms(2) by auto
  } hence "l1 l2. l1  l2 
              GSMP_disjoint (trmssst (proj_unl l1 𝒜)  pair ` setopssst (proj_unl l1 𝒜))
                            (trmssst (proj_unl l2 𝒜)  pair ` setopssst (proj_unl l2 𝒜)) Sec"
    by metis
  moreover have "(i,p)  setopslsst 𝒜. (j,q)  setopslsst 𝒜.
                    (δ. Unifier δ (pair p) (pair q))  i = j"
    using assms(1,2) unfolding par_comp_prot_stateful_def by blast
  ultimately show ?thesis
    using assms
    unfolding par_comp_prot_stateful_def par_complsst_def
    by fast
qed

lemma typing_cond_prot_impl_typing_cond_stateful:
  assumes "typing_cond_prot_stateful 𝒫" "𝒜  𝒫"
  shows "typing_condsst (unlabel 𝒜)"
proof -
  have 1: "wf'sst {} (unlabel 𝒜)" "fvlsst 𝒜  bvarslsst 𝒜 = {}"
    using assms unfolding typing_cond_prot_stateful_def wflssts_def by auto

  have "tfrset ((trmslsst ` 𝒫)  pair ` (setopssst ` unlabel ` 𝒫))"
       "wftrms ((trmslsst ` 𝒫))"
       "trmslsst 𝒜  (trmslsst ` 𝒫)"
       "SMP (trmslsst 𝒜  pair ` setopssst (unlabel 𝒜)) - Var`𝒱 
        SMP ((trmslsst ` 𝒫)  pair ` (setopssst ` unlabel ` 𝒫)) - Var`𝒱"
    using assms SMP_mono[of "trmslsst 𝒜  pair ` setopssst (unlabel 𝒜)"
                            "(trmslsst ` 𝒫)  pair ` (setopssst ` unlabel ` 𝒫)"]
    unfolding typing_cond_prot_stateful_def
    by (metis, metis, auto)
  hence 2: "tfrset (trmslsst 𝒜  pair ` setopssst (unlabel 𝒜))" and 3: "wftrms (trmslsst 𝒜)"
    unfolding tfrset_def by (meson subsetD)+

  have 4: "list_all tfrsstp (unlabel 𝒜)" using assms unfolding typing_cond_prot_stateful_def by auto

  show ?thesis using 1 2 3 4 unfolding typing_condsst_def tfrsst_def by blast
qed

theorem par_comp_constr_prot_stateful:
  assumes P: "P = composed_prot Pi" "par_comp_prot_stateful P Sec" "n. component_prot n (Pi n)"
  and left_secure: "component_secure_prot_stateful n (Pi n) Sec attack"
  shows "𝒜  P. suffix [(ln n, Send (Fun attack []))] 𝒜 
                  unsat_stateful 𝒜  (m. n  m  component_leaks_stateful m 𝒜 Sec)"
proof -
  { fix 𝒜 𝒜' assume 𝒜: "𝒜 = 𝒜'@[(ln n, Send (Fun attack []))]" "𝒜  P"
    let ?P = "𝒜' τ. interpretationsubst τ  wtsubst τ  wftrms (subst_range τ)  prefix 𝒜' 𝒜 
                   (t  Sec-declassifiedlsst 𝒜' τ. m. n  m  (τ s (proj_unl m 𝒜'@[Send t])))"
    have tcp: "typing_cond_prot_stateful P" using P(2) unfolding par_comp_prot_stateful_def by simp
    have par_comp: "par_complsst 𝒜 Sec" "typing_condsst (unlabel 𝒜)"
      using par_comp_prot_impl_par_comp_stateful[OF P(2) 𝒜(2)]
            typing_cond_prot_impl_typing_cond_stateful[OF tcp 𝒜(2)]
      by metis+

    have "unlabel (proj n 𝒜) = proj_unl n 𝒜" "proj_unl n 𝒜 = proj_unl n (proj n 𝒜)"
         "A. A  Pi n  proj n A = A"
         "proj n 𝒜 = (proj n 𝒜')@[(ln n, Send (Fun attack []))]"
      using P(1,3) 𝒜 by (auto simp add: proj_def unlabel_def component_prot_def composed_prot_def)
    moreover have "proj n 𝒜  Pi n"
      using P(1) 𝒜 unfolding composed_prot_def by blast
    moreover {
      fix A assume "prefix A 𝒜"
      hence *: "prefix (proj n A) (proj n 𝒜)" unfolding proj_def prefix_def by force
      hence "proj_unl n A = proj_unl n (proj n A)"
            "I. declassifiedlsst A I = declassifiedlsst (proj n A) I"
        unfolding proj_def declassifiedlsst_def by auto
      hence "B. prefix B (proj n 𝒜)  proj_unl n A = proj_unl n B 
                 (I. declassifiedlsst A I = declassifiedlsst B I)"
        using * by metis
    }
    ultimately have *:
        "τ. interpretationsubst τ  wtsubst τ  wftrms (subst_range τ) 
                  ¬(τ s (proj_unl n 𝒜))  (𝒜'. prefix 𝒜' 𝒜 
                        (t  Sec - declassifiedlsst 𝒜' τ. ¬(τ s (proj_unl n 𝒜'@[Send t]))))"
      using left_secure
      unfolding component_secure_prot_stateful_def composed_prot_def suffix_def
      by metis
    { fix  assume: "interpretationsubst " " s unlabel 𝒜"
      obtain τ whereτ:
          "interpretationsubst τ" "wtsubst τ" "wftrms (subst_range τ)"
          "𝒜'. prefix 𝒜' 𝒜  (𝒜' leaks Sec under τ)"
        using par_comp_constr_stateful[OF par_comp ℐ(2,1)] * by moura
      hence "𝒜'. prefix 𝒜' 𝒜  (t  Sec - declassifiedlsst 𝒜' τ. m.
                  n  m  (τ s (proj_unl m 𝒜'@[Send t])))"
        usingτ(4) * unfolding strand_leakslsst_def by metis
      hence ?P usingτ(1,2,3) by auto
    } hence "unsat_stateful 𝒜  (m. n  m  component_leaks_stateful m 𝒜 Sec)"
      by (metis unsat_stateful_def component_leaks_stateful_def)
  } thus ?thesis unfolding suffix_def by metis
qed

end

subsection ‹Automated Compositionality Conditions›
definition comp_GSMP_disjoint where
  "comp_GSMP_disjoint public arity Ana Γ A' B' A B C 
    let  = B list var_rename (max_var_set (fvset (set A)))
    in has_all_wt_instances_of Γ (set A') (set A) 
       has_all_wt_instances_of Γ (set B') (set ) 
       finite_SMP_representation arity Ana Γ A 
       finite_SMP_representation arity Ana Γ  
       (t  set A. s  set . Γ t = Γ s  mgu t s  None 
         (intruder_synth' public arity {} t  intruder_synth' public arity {} s) 
         (u  set C. is_wt_instance_of_cond Γ t u)  (u  set C. is_wt_instance_of_cond Γ s u))"

definition comp_par_complsst where
  "comp_par_complsst public arity Ana Γ pair_fun A M C 
  let L = remdups (map (the_LabelN  fst) (filter (Not  is_LabelS) A));
      MP0 = λB. remdups (trms_listsst B@map (pair' pair_fun) (setops_listsst B));
      pr = λl. MP0 (proj_unl l A)
  in length L > 1 
     list_all (wftrm' arity) (MP0 (unlabel A)) 
     list_all (wftrm' arity) C 
     has_all_wt_instances_of Γ (subtermsset (set C)) (set C) 
     is_TComp_var_instance_closed Γ C 
     (i  set L. j  set L. i  j 
        comp_GSMP_disjoint public arity Ana Γ (pr i) (pr j) (M i) (M j) C) 
     ((i,p)  setopslsst A. (j,q)  setopslsst A. i  j 
        (let s = pair' pair_fun p; t = pair' pair_fun q
         in mgu s (t  var_rename (max_var s)) = None))"

locale labeled_stateful_typed_model' =
  stateful_typed_model' arity public Ana Γ Pair
+ labeled_typed_model' arity public Ana Γ label_witness1 label_witness2
  for arity::"'fun  nat"
  and public::"'fun  bool"
  and Ana::"('fun,(('fun,'atom::finite) term_type × nat)) term
             (('fun,(('fun,'atom) term_type × nat)) term list
               × ('fun,(('fun,'atom) term_type × nat)) term list)"
  and Γ::"('fun,(('fun,'atom) term_type × nat)) term  ('fun,'atom) term_type"
  and Pair::"'fun"
  and label_witness1::"'lbl"
  and label_witness2::"'lbl"
begin

sublocale labeled_stateful_typed_model
by unfold_locales

lemma GSMP_disjoint_if_comp_GSMP_disjoint:
  defines "f  λM. {t  δ | t δ. t  M  wtsubst δ  wftrms (subst_range δ)  fv (t  δ) = {}}"
  assumes AB'_wf: "list_all (wftrm' arity) A'" "list_all (wftrm' arity) B'"
    and C_wf: "list_all (wftrm' arity) C"
    and AB'_disj: "comp_GSMP_disjoint public arity Ana Γ A' B' A B C"
  shows "GSMP_disjoint (set A') (set B') ((f (set C)) - {m. {} c m})"
using GSMP_disjointI[of A' B' A B] AB'_wf AB'_disj C_wf
unfolding comp_GSMP_disjoint_def f_def wftrm_code list_all_iff Let_def by fast

lemma par_complsst_if_comp_par_complsst:
  defines "f  λM. {t  δ | t δ. t  M  wtsubst δ  wftrms (subst_range δ)  fv (t  δ) = {}}"
  assumes A: "comp_par_complsst public arity Ana Γ Pair A M C"
  shows "par_complsst A ((f (set C)) - {m. {} c m})"
proof (unfold par_complsst_def; intro conjI)
  let ?Sec = "(f (set C)) - {m. {} c m}"
  let ?L = "remdups (map (the_LabelN  fst) (filter (Not  is_LabelS) A))"
  let ?N1 = "λB. remdups (trms_listsst B@map (pair' Pair) (setops_listsst B))"
  let ?N2 = "λB. trmssst B  pair ` setopssst B"
  let ?pr = "λl. ?N1 (proj_unl l A)"
  let  = "λp. var_rename (max_var (pair p))"

  have 0:
      "length ?L > 1"
      "list_all (wftrm' arity) (?N1 (unlabel A))"
      "list_all (wftrm' arity) C"
      "has_all_wt_instances_of Γ (subtermsset (set C)) (set C)"
      "is_TComp_var_instance_closed Γ C"
      "i  set ?L. j  set ?L. i  j 
        comp_GSMP_disjoint public arity Ana Γ (?pr i) (?pr j) (M i) (M j) C"
      "(i,p)  setopslsst A. (j,q)  setopslsst A. i  j  mgu (pair p) (pair q   p) = None"
    using A unfolding comp_par_complsst_def pair_code by meson+

  have L_in_iff: "l  set ?L  (a  set A. is_LabelN l a)" for l by force

  have A_wf_trms: "wftrms (trmslsst A  pair ` setopssst (unlabel A))"
    using 0(2)
    unfolding pair_code wftrm_code list_all_iff trms_listsst_is_trmssst setops_listsst_is_setopssst
    by auto
  hence A_proj_wf_trms: "wftrms (trmslsst (proj l A)  pair ` setopssst (proj_unl l A))" for l
    using trmssst_proj_subset(1)[of l A] setopssst_proj_subset(1)[of l A] by blast
  hence A_proj_wf_trms': "list_all (wftrm' arity) (?N1 (proj_unl l A))" for l
    unfolding pair_code wftrm_code list_all_iff trms_listsst_is_trmssst setops_listsst_is_setopssst
    by auto

  note C_wf_trms = 0(3)[unfolded list_all_iff wftrm_code[symmetric]]

  note 1 = has_all_wt_instances_ofD'[OF wf_trms_subterms[OF C_wf_trms] C_wf_trms 0(4)]

  have 2: "GSMP (?N2 (proj_unl l A))  GSMP (?N2 (proj_unl l' A))" when "l  set ?L" for l l'
    using that L_in_iff GSMP_mono[of "?N2 (proj_unl l A)" "?N2 (proj_unl l' A)"]
          trmssst_unlabel_subset_if_no_label[of l A]
          setopssst_unlabel_subset_if_no_label[of l A]
    unfolding list_ex_iff by fast

  have 3: "GSMP_disjoint (?N2 (proj_unl l1 A)) (?N2 (proj_unl l2 A)) ?Sec"
    when "l1  set ?L" "l2  set ?L" "l1  l2" for l1 l2
  proof -
    have "GSMP_disjoint (set (?N1 (proj_unl l1 A))) (set (?N1 (proj_unl l2 A))) ?Sec"
      using 0(6) that
            GSMP_disjoint_if_comp_GSMP_disjoint[
              OF A_proj_wf_trms'[of l1] A_proj_wf_trms'[of l2] 0(3),
              of "M l1" "M l2"]
      unfolding f_def by blast
    thus ?thesis
      unfolding pair_code trms_listsst_is_trmssst setops_listsst_is_setopssst
      by simp
  qed

  obtain a1 a2 where a: "a1  set ?L" "a2  set ?L" "a1  a2"
    using remdups_ex2[OF 0(1)] by moura

  show "ground ?Sec" unfolding f_def by fastforce

  { fix i p j q
    assume p: "(i,p)  setopslsst A" and q: "(j,q)  setopslsst A"
      and pq: "δ. Unifier δ (pair p) (pair q)"

    have "δ. Unifier δ (pair p) (pair q   p)"
      using pq vars_term_disjoint_imp_unifier[OF var_rename_fv_disjoint[of "pair p"], of _ "pair q"]
      by (metis (no_types, lifting) subst_subst_compose var_rename_inv_comp)
    hence "i = j" using 0(7) mgu_None_is_subst_neq[of "pair p" "pair q   p"] p q by fast
  } thus "(i,p)  setopslsst A. (j,q)  setopslsst A. (δ. Unifier δ (pair p) (pair q))  i = j"
    by blast

  show "l1 l2. l1  l2  GSMP_disjoint (?N2 (proj_unl l1 A)) (?N2 (proj_unl l2 A)) ?Sec"
    using 2 3 3[OF a] unfolding GSMP_disjoint_def by blast

  show "s  ?Sec. s'  subterms s. {} c s'  s'  ?Sec"
  proof (intro ballI)
    fix s s'
    assume s: "s  ?Sec" and s': "s'  s"
    then obtain t δ where t: "t  set C" "s = t  δ" "fv s = {}" "¬{} c s"
        and δ: "wtsubst δ" "wftrms (subst_range δ)"
      unfolding f_def by blast

    obtain m θ where m: "m  set C" "s' = m  θ" and θ: "wtsubst θ" "wftrms (subst_range θ)"
      using TComp_var_and_subterm_instance_closed_has_subterms_instances[
              OF 0(5,4) C_wf_trms in_subterms_Union[OF t(1)] s'[unfolded t(2)] δ]
      by blast
    thus "{} c s'  s'  ?Sec"
      using ground_subterm[OF t(3) s']
      unfolding f_def by blast
  qed
qed

lemma par_complsst_if_comp_par_complsst':
  defines "f  λM. {t  δ | t δ. t  M  wtsubst δ  wftrms (subst_range δ)  fv (t  δ) = {}}"
  assumes a: "comp_par_complsst public arity Ana Γ Pair A M C"
    and B: "b  set B. a  set A. δ. b = a lsstp δ  wtsubst δ  wftrms (subst_range δ)"
      (is "b  set B. a  set A. δ. b = a lsstp δ  ?D δ")
  shows "par_complsst B ((f (set C)) - {m. {} c m})"
proof (unfold par_complsst_def; intro conjI)
  define N1 where "N1  λB::('fun, ('fun,'atom) term_type × nat) stateful_strand.
    remdups (trms_listsst B@map (pair' Pair) (setops_listsst B))"

  define N2 where "N2  λB::('fun, ('fun,'atom) term_type × nat) stateful_strand.
    trmssst B  pair ` setopssst B"

  define L where "L  λA::('fun, ('fun,'atom) term_type × nat, 'lbl) labeled_stateful_strand.
    remdups (map (the_LabelN  fst) (filter (Not  is_LabelS) A))"

  define α where "α  λp. var_rename (max_var (pair p::('fun, ('fun,'atom) term_type × nat) term))
    ::('fun, ('fun,'atom) term_type × nat) subst"

  let ?Sec = "(f (set C)) - {m. {} c m}"

  have 0:
      "length (L A) > 1"
      "list_all (wftrm' arity) (N1 (unlabel A))"
      "list_all (wftrm' arity) C"
      "has_all_wt_instances_of Γ (subtermsset (set C)) (set C)"
      "is_TComp_var_instance_closed Γ C"
      "i  set (L A). j  set (L A). i  j 
        comp_GSMP_disjoint public arity Ana Γ (N1 (proj_unl i A)) (N1 (proj_unl j A)) (M i) (M j) C"
      "(i,p)  setopslsst A. (j,q)  setopslsst A. i  j  mgu (pair p) (pair q  α p) = None"
    using a unfolding comp_par_complsst_def pair_code L_def N1_def α_def by meson+

  note 1 = trmssst_proj_subset(1) setopssst_proj_subset(1)

  have N1_iff_N2: "set (N1 A) = N2 A" for A
    unfolding pair_code trms_listsst_is_trmssst setops_listsst_is_setopssst N1_def N2_def by simp

  have N2_proj_subset: "N2 (proj_unl l A)  N2 (unlabel A)"
    for l::'lbl and A::"('fun, ('fun,'atom) term_type × nat, 'lbl) labeled_stateful_strand"
    using 1(1)[of l A] image_mono[OF 1(2)[of l A], of pair] unfolding N2_def by blast

  have L_in_iff: "l  set (L A)  (a  set A. is_LabelN l a)" for l A
    unfolding L_def by force

  have L_B_subset_A: "l  set (L A)" when l: "l  set (L B)" for l
    using L_in_iff[of l B] L_in_iff[of l A] B l by fastforce

  note B_setops = setopslsst_wt_instance_ex[OF B]

  have B_proj: "b  set (proj l B). a  set (proj l A). δ. b = a lsstp δ  ?D δ" for l
    using proj_instance_ex[OF B] by fast

  have B': "t  N2 (unlabel B). s  N2 (unlabel A). δ. t = s  δ  ?D δ"
    using trmssst_setopssst_wt_instance_ex[OF B] unfolding N2_def by blast

  have B'_proj: "t  N2 (proj_unl l B). s  N2 (proj_unl l A). δ. t = s  δ  ?D δ" for l
    using trmssst_setopssst_wt_instance_ex[OF B_proj] unfolding N2_def by presburger

  have A_wf_trms: "wftrms (N2 (unlabel A))"
    using N1_iff_N2[of "unlabel A"] 0(2) unfolding wftrm_code list_all_iff by auto
  hence A_proj_wf_trms: "wftrms (N2 (proj_unl l A))" for l
    using 1[of l] unfolding N2_def by blast
  hence A_proj_wf_trms': "list_all (wftrm' arity) (N1 (proj_unl l A))" for l
    using N1_iff_N2[of "proj_unl l A"] unfolding wftrm_code list_all_iff by presburger

  note C_wf_trms = 0(3)[unfolded list_all_iff wftrm_code[symmetric]]

  have 2: "GSMP (N2 (proj_unl l A))  GSMP (N2 (proj_unl l' A))"
    when "l  set (L A)" for l l'
      and A::"('fun, ('fun,'atom) term_type × nat, 'lbl) labeled_stateful_strand"
    using that L_in_iff[of _ A] GSMP_mono[of "N2 (proj_unl l A)" "N2 (proj_unl l' A)"]
          trmssst_unlabel_subset_if_no_label[of l A]
          setopssst_unlabel_subset_if_no_label[of l A]
    unfolding list_ex_iff N2_def by fast

  have 3: "GSMP (N2 (proj_unl l B))  GSMP (N2 (proj_unl l A))" (is "?X  ?Y") for l
  proof
    fix t assume "t  ?X"
    hence t: "t  SMP (N2 (proj_unl l B))" "fv t = {}" unfolding GSMP_def by simp_all
    have "t  SMP (N2 (proj_unl l A))"
      using t(1) B'_proj[of l] SMP_wt_instances_subset[of "N2 (proj_unl l B)" "N2 (proj_unl l A)"]
      by metis
    thus "t  ?Y" using t(2) unfolding GSMP_def by fast
  qed

  have "GSMP_disjoint (N2 (proj_unl l1 A)) (N2 (proj_unl l2 A)) ?Sec"
    when "l1  set (L A)" "l2  set (L A)" "l1  l2" for l1 l2
  proof -
    have "GSMP_disjoint (set (N1 (proj_unl l1 A))) (set (N1 (proj_unl l2 A))) ?Sec"
      using 0(6) that
            GSMP_disjoint_if_comp_GSMP_disjoint[
              OF A_proj_wf_trms'[of l1] A_proj_wf_trms'[of l2] 0(3),
              of "M l1" "M l2"]
      unfolding f_def by blast
    thus ?thesis using N1_iff_N2 by simp
  qed
  hence 4: "GSMP_disjoint (N2 (proj_unl l1 B)) (N2 (proj_unl l2 B)) ?Sec"
    when "l1  set (L A)" "l2  set (L A)" "l1  l2" for l1 l2
    using that 3 unfolding GSMP_disjoint_def by blast

  { fix i p j q
    assume p: "(i,p)  setopslsst B" and q: "(j,q)  setopslsst B"
      and pq: "δ. Unifier δ (pair p) (pair q)"

    obtain p' δp where p': "(i,p')  setopslsst A" "p = p' p δp" "pair p = pair p'  δp"
      using p B_setops unfolding pair_def by auto

    obtain q' δq where q': "(j,q')  setopslsst A" "q = q' p δq" "pair q = pair q'  δq"
      using q B_setops unfolding pair_def by auto

    obtain θ where "Unifier θ (pair p) (pair q)" using pq by blast
    hence "δ. Unifier δ (pair p') (pair q'  α p')"
      using p'(3) q'(3) var_rename_inv_comp[of "pair q'"] subst_subst_compose
            vars_term_disjoint_imp_unifier[
              OF var_rename_fv_disjoint[of "pair p'"],
              of "δp s θ" "pair q'" "var_rename_inv (max_var_set (fv (pair p'))) s δq s θ"]
      unfolding α_def by fastforce
    hence "i = j"
      using mgu_None_is_subst_neq[of "pair p'" "pair q'  α p'"] p'(1) q'(1) 0(7)
      unfolding α_def by fast
  } thus "(i,p)  setopslsst B. (j,q)  setopslsst B. (δ. Unifier δ (pair p) (pair q))  i = j"
    by blast

  obtain a1 a2 where a: "a1  set (L A)" "a2  set (L A)" "a1  a2"
    using remdups_ex2[OF 0(1)[unfolded L_def]] unfolding L_def by moura

  show "l1 l2. l1  l2  GSMP_disjoint (N2 (proj_unl l1 B)) (N2 (proj_unl l2 B)) ?Sec"
    using 2[of _ B] 4 4[OF a] L_B_subset_A unfolding GSMP_disjoint_def by blast

  show "ground ?Sec" unfolding f_def by fastforce

  show "s  ?Sec. s'  subterms s. {} c s'  s'  ?Sec"
  proof (intro ballI)
    fix s s'
    assume s: "s  ?Sec" and s': "s'  s"
    then obtain t δ where t: "t  set C" "s = t  δ" "fv s = {}" "¬{} c s"
        and δ: "wtsubst δ" "wftrms (subst_range δ)"
      unfolding f_def by blast

    obtain m θ where m: "m  set C" "s' = m  θ" and θ: "wtsubst θ" "wftrms (subst_range θ)"
      using TComp_var_and_subterm_instance_closed_has_subterms_instances[
              OF 0(5,4) C_wf_trms in_subterms_Union[OF t(1)] s'[unfolded t(2)] δ]
      by blast
    thus "{} c s'  s'  ?Sec"
      using ground_subterm[OF t(3) s']
      unfolding f_def by blast
  qed
qed

end

end

Theory Example_Keyserver

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Example_Keyserver.thy
    Author:     Andreas Viktor Hess, DTU
*)


section ‹The Keyserver Example›
text ‹\label{sec:Example-Keyserver}›
theory Example_Keyserver
imports "../Stateful_Compositionality"
begin

declare [[code_timing]]

subsection ‹Setup›
subsubsection ‹Datatypes and functions setup›
datatype ex_lbl = Label1 ("𝟭") | Label2 ("𝟮")

datatype ex_atom =
  Agent | Value | Attack | PrivFunSec
| Bot

datatype ex_fun =
  ring | valid | revoked | events | beginauth nat | endauth nat | pubkeys | seen
| invkey | tuple | tuple' | attack nat
| sign | crypt | update | pw
| encodingsecret | pubkey nat
| pubconst ex_atom nat

type_synonym ex_type = "(ex_fun, ex_atom) term_type"
type_synonym ex_var = "ex_type × nat"

lemma ex_atom_UNIV:
  "(UNIV::ex_atom set) = {Agent, Value, Attack, PrivFunSec, Bot}"
by (auto intro: ex_atom.exhaust)

instance ex_atom::finite
by intro_classes (metis ex_atom_UNIV finite.emptyI finite.insertI)

lemma ex_lbl_UNIV:
  "(UNIV::ex_lbl set) = {Label1, Label2}"
by (auto intro: ex_lbl.exhaust)

type_synonym ex_term = "(ex_fun, ex_var) term"
type_synonym ex_terms = "(ex_fun, ex_var) terms"

primrec arity::"ex_fun  nat" where
  "arity ring = 2"
| "arity valid = 3"
| "arity revoked = 3"
| "arity events = 1"
| "arity (beginauth _) = 3"
| "arity (endauth _) = 3"
| "arity pubkeys = 2"
| "arity seen = 2"
| "arity invkey = 2"
| "arity tuple = 2"
| "arity tuple' = 2"
| "arity (attack _) = 0"
| "arity sign = 2"
| "arity crypt = 2"
| "arity update = 4"
| "arity pw = 2"
| "arity (pubkey _) = 0"
| "arity encodingsecret = 0"
| "arity (pubconst _ _) = 0"

fun public::"ex_fun  bool" where
  "public (pubkey _) = False"
| "public encodingsecret = False"
| "public _ = True"

fun Anacrypt::"ex_term list  (ex_term list × ex_term list)" where
  "Anacrypt [k,m] = ([Fun invkey [Fun encodingsecret [], k]], [m])"
| "Anacrypt _ = ([], [])"

fun Anasign::"ex_term list  (ex_term list × ex_term list)" where
  "Anasign [k,m] = ([], [m])"
| "Anasign _ = ([], [])"

fun Ana::"ex_term  (ex_term list × ex_term list)" where
  "Ana (Fun tuple T) = ([], T)"
| "Ana (Fun tuple' T) = ([], T)"
| "Ana (Fun sign T) = Anasign T"
| "Ana (Fun crypt T) = Anacrypt T"
| "Ana _ = ([], [])"


subsubsection ‹Keyserver example: Locale interpretation›
lemma assm1:
  "Ana t = (K,M)  fvset (set K)  fv t"
  "Ana t = (K,M)  (g S'. Fun g S'  t  length S' = arity g)
                 k  set K  Fun f T'  k  length T' = arity f"
  "Ana t = (K,M)  K  []  M  []  Ana (t  δ) = (K list δ, M list δ)"
by (rule Ana.cases[of "t"], auto elim!: Anacrypt.elims Anasign.elims)+

lemma assm2: "Ana (Fun f T) = (K, M)  set M  set T"
by (rule Ana.cases[of "Fun f T"]) (auto elim!: Anacrypt.elims Anasign.elims)

lemma assm6: "0 < arity f  public f" by (cases f) simp_all

global_interpretation im: intruder_model arity public Ana
  defines wftrm = "im.wftrm"
by unfold_locales (metis assm1(1), metis assm1(2),rule Ana.simps, metis assm2, metis assm1(3))

type_synonym ex_strand_step = "(ex_fun,ex_var) strand_step"
type_synonym ex_strand = "(ex_fun,ex_var) strand"


subsubsection ‹Typing function›
definition Γv::"ex_var  ex_type" where
  "Γv v = (if (t  subterms (fst v). case t of
                (TComp f T)  arity f > 0  arity f = length T
              | _  True)
           then fst v else TAtom Bot)"

fun Γ::"ex_term  ex_type" where
  "Γ (Var v) = Γv v"
| "Γ (Fun (attack _) _) = TAtom Attack"
| "Γ (Fun (pubkey _) _) = TAtom Value"
| "Γ (Fun encodingsecret _) = TAtom PrivFunSec"
| "Γ (Fun (pubconst τ _) _) = TAtom τ"
| "Γ (Fun f T) = TComp f (map Γ T)"


subsubsection ‹Locale interpretation: typed model›
lemma assm7: "arity c = 0  a. X. Γ (Fun c X) = TAtom a" by (cases c) simp_all

lemma assm8: "0 < arity f  Γ (Fun f X) = TComp f (map Γ X)" by (cases f) simp_all

lemma assm9: "infinite {c. Γ (Fun c []) = TAtom a  public c}"
proof -
  let ?T = "(range (pubconst a))::ex_fun set"
  have *:
      "x y::nat. x  UNIV  y  UNIV  (pubconst a x = pubconst a y) = (x = y)"
      "x::nat. x  UNIV  pubconst a x  ?T"
      "y::ex_fun. y  ?T  x  UNIV. y = pubconst a x"
    by auto
  have "?T  {c. Γ (Fun c []) = TAtom a  public c}" by auto
  moreover have "f::nat  ex_fun. bij_betw f UNIV ?T"
    using bij_betwI'[OF *] by blast
  hence "infinite ?T" by (metis nat_not_finite bij_betw_finite)
  ultimately show ?thesis using infinite_super by blast
qed

lemma assm10: "TComp f T  Γ t  arity f > 0"
proof (induction rule: Γ.induct)
  case (1 x)
  hence *: "TComp f T  Γv x" by simp
  hence v x  TAtom Bot" unfolding Γv_def by force
  hence "t  subterms (fst x). case t of
            (TComp f T)  arity f > 0  arity f = length T
          | _  True"
    unfolding Γv_def by argo
  thus ?case using * unfolding Γv_def by fastforce 
qed auto

lemma assm11: "im.wftrm (Γ (Var x))"
proof -
  have "im.wftrm (Γv x)" unfolding Γv_def im.wftrm_def by auto 
  thus ?thesis by simp
qed

lemma assm12: (Var (τ, n)) = Γ (Var (τ, m))"
apply (cases "t  subterms τ. case t of
                (TComp f T)  arity f > 0  arity f = length T
              | _  True")
by (auto simp add: Γv_def)

lemma Ana_const: "arity c = 0  Ana (Fun c T) = ([], [])"
by (cases c) simp_all

lemma Ana_subst': "Ana (Fun f T) = (K,M)  Ana (Fun f T  δ) = (K list δ,M list δ)"
by (cases f) (auto elim!: Anacrypt.elims Anasign.elims)

global_interpretation tm: typed_model' arity public Ana Γ
by (unfold_locales, unfold wftrm_def[symmetric])
   (metis assm7, metis assm8, metis assm9, metis assm10, metis assm11, metis assm6,
    metis assm12, metis Ana_const, metis Ana_subst')


subsubsection ‹Locale interpretation: labeled stateful typed model›
global_interpretation stm: labeled_stateful_typed_model' arity public Ana Γ tuple 𝟭 𝟮
by standard (rule arity.simps, metis Ana_subst', metis assm12, metis Ana_const, simp)

type_synonym ex_stateful_strand_step = "(ex_fun,ex_var) stateful_strand_step"
type_synonym ex_stateful_strand = "(ex_fun,ex_var) stateful_strand"

type_synonym ex_labeled_stateful_strand_step =
  "(ex_fun,ex_var,ex_lbl) labeled_stateful_strand_step"

type_synonym ex_labeled_stateful_strand =
  "(ex_fun,ex_var,ex_lbl) labeled_stateful_strand"


subsection ‹Theorem: Type-flaw resistance of the keyserver example from the CSF18 paper›
abbreviation "PK n  Var (TAtom Value,n)"
abbreviation "A n  Var (TAtom Agent,n)"
abbreviation "X n  (TAtom Agent,n)"

abbreviation "ringset t  Fun ring [Fun encodingsecret [], t]"
abbreviation "validset t t'  Fun valid [Fun encodingsecret [], t, t']"
abbreviation "revokedset t t'  Fun revoked [Fun encodingsecret [], t, t']"
abbreviation "eventsset  Fun events [Fun encodingsecret []]"

(* Note: We will use Sks as a constraint, but it actually represents all steps that might occur
         in the protocol *)
abbreviation Sks::"(ex_fun,ex_var) stateful_strand_step list" where
  "Sks  [
    insert⟨Fun (attack 0) [], eventsset,
    delete⟨PK 0, validset (A 0) (A 0),
    (TAtom Agent,0)PK 0 not in revokedset (A 0) (A 0),
    (TAtom Agent,0)PK 0 not in validset (A 0) (A 0),
    insert⟨PK 0, validset (A 0) (A 0),
    insert⟨PK 0, ringset (A 0),
    insert⟨PK 0, revokedset (A 0) (A 0),
    select⟨PK 0, validset (A 0) (A 0),
    select⟨PK 0, ringset (A 0),
    receive⟨Fun invkey [Fun encodingsecret [], PK 0],
    receive⟨Fun sign [Fun invkey [Fun encodingsecret [], PK 0], Fun tuple' [A 0, PK 0]],
    send⟨Fun invkey [Fun encodingsecret [], PK 0],
    send⟨Fun sign [Fun invkey [Fun encodingsecret [], PK 0], Fun tuple' [A 0, PK 0]]
]"

theorem "stm.tfrsst Sks"
proof -
  let ?M = "concat (map subterms_list (trms_listsst Sks@map (pair' tuple) (setops_listsst Sks)))"
  have "comp_tfrsst arity Ana Γ tuple ?M Sks" by eval
  thus ?thesis by (rule stm.tfrsst_if_comp_tfrsst)
qed


subsection ‹Theorem: Type-flaw resistance of the keyserver examples from the ESORICS18 paper›
abbreviation "signmsg t t'  Fun sign [t, t']"
abbreviation "cryptmsg t t'  Fun crypt [t, t']"
abbreviation "invkeymsg t  Fun invkey [Fun encodingsecret [], t]"
abbreviation "updatemsg a b c d  Fun update [a,b,c,d]"
abbreviation "pwmsg t t'  Fun pw [t, t']"

abbreviation "beginauthset n t t'  Fun (beginauth n) [Fun encodingsecret [], t, t']"
abbreviation "endauthset n t t'  Fun (endauth n) [Fun encodingsecret [], t, t']"
abbreviation "pubkeysset t  Fun pubkeys [Fun encodingsecret [], t]"
abbreviation "seenset t  Fun seen [Fun encodingsecret [], t]"

declare [[coercion "Var::ex_var  ex_term"]]
declare [[coercion_enabled]]

(* Note: S'ks contains the (slightly over-approximated) steps that can occur in the
         reachable constraints of 𝒫ks,1 and 𝒫ks,2 modulo variable renaming *)
definition S'ks::"ex_labeled_stateful_strand_step list" where
  "S'ks  [
⌦‹constraint steps from the first protocol (duplicate steps are ignored)›

    ⌦‹rule R^1_1›
    𝟭, send⟨invkeymsg (PK 0),
    ⟨⋆, PK 0 in validset (A 0) (A 1),
    𝟭, receive⟨Fun (attack 0) [],

    ⌦‹rule R^2_1›
    𝟭, send⟨signmsg (invkeymsg (PK 0)) (Fun tuple' [A 0, PK 0]),
    ⟨⋆, PK 0 in validset (A 0) (A 1),
    ⟨⋆, X 0, X 1PK 0 not in validset (Var (X 0)) (Var (X 1)),
    𝟭, X 0, X 1PK 0 not in revokedset (Var (X 0)) (Var (X 1)),
    ⟨⋆, PK 0 not in beginauthset 0 (A 0) (A 1),

    ⌦‹rule R^3_1›
    ⟨⋆, PK 0 in beginauthset 0 (A 0) (A 1),
    ⟨⋆, PK 0 in endauthset 0 (A 0) (A 1),

    ⌦‹rule R^4_1›
    ⟨⋆, receive⟨PK 0,
    ⟨⋆, receive⟨invkeymsg (PK 0),

    ⌦‹rule R^5_1›
    𝟭, insert⟨PK 0, ringset (A 0),
    ⟨⋆, insert⟨PK 0, validset (A 0) (A 1),
    ⟨⋆, insert⟨PK 0, beginauthset 0 (A 0) (A 1),
    ⟨⋆, insert⟨PK 0, endauthset 0 (A 0) (A 1),

    ⌦‹rule R^6_1›
    𝟭, select⟨PK 0, ringset (A 0),
    𝟭, delete⟨PK 0, ringset (A 0),
    
    ⌦‹rule R^7_1›
    ⟨⋆, PK 0 not in endauthset 0 (A 0) (A 1),
    ⟨⋆, delete⟨PK 0, validset (A 0) (A 1),
    𝟭, insert⟨PK 0, revokedset (A 0) (A 1),

    ⌦‹rule R^8_1›
    ⌦‹nothing new›

    ⌦‹rule R^9_1›
    𝟭, send⟨PK 0,
    
    ⌦‹rule R^10_1›
    𝟭, send⟨Fun (attack 0) [],

⌦‹constraint steps from the second protocol (duplicate steps are ignored)›
    ⌦‹rule R^2_1›
    𝟮, send⟨invkeymsg (PK 0),
    ⟨⋆, PK 0 in validset (A 0) (A 1),
    𝟮, receive⟨Fun (attack 1) [],

    ⌦‹rule R^2_2›
    𝟮, send⟨cryptmsg (PK 0) (updatemsg (A 0) (A 1) (PK 1) (pwmsg (A 0) (A 1))),
    𝟮, select⟨PK 0, pubkeysset (A 0),
    𝟮, X 0PK 0 not in pubkeysset (Var (X 0)),
    𝟮, X 0PK 0 not in seenset (Var (X 0)),

    ⌦‹rule R^3_2›
    ⟨⋆, PK 0 in beginauthset 1 (A 0) (A 1),
    ⟨⋆, PK 0 in endauthset 1 (A 0) (A 1),

    ⌦‹rule R^4_2›
    ⟨⋆, receive⟨PK 0,
    ⟨⋆, receive⟨invkeymsg (PK 0),

    ⌦‹rule R^5_2›
    𝟮, select⟨PK 0, pubkeysset (A 0),
    ⟨⋆, insert⟨PK 0, beginauthset 1 (A 0) (A 1),
    𝟮, receive⟨cryptmsg (PK 0) (updatemsg (A 0) (A 1) (PK 1) (pwmsg (A 0) (A 1))),

    ⌦‹rule R^6_2›
    ⟨⋆, PK 0 not in endauthset 1 (A 0) (A 1),
    ⟨⋆, insert⟨PK 0, validset (A 0) (A 1),
    ⟨⋆, insert⟨PK 0, endauthset 1 (A 0) (A 1),
    𝟮, insert⟨PK 0, seenset (A 0),

    ⌦‹rule R^7_2›
    𝟮, receive⟨pwmsg (A 0) (A 1),

    ⌦‹rule R^8_2›
    ⌦‹nothing new›

    ⌦‹rule R^9_2›
    𝟮, insert⟨PK 0, pubkeysset (A 0),

    ⌦‹rule R^10_2›
    𝟮, send⟨Fun (attack 1) []
]"

theorem "stm.tfrsst (unlabel S'ks)"
proof -
  let ?S = "unlabel S'ks"
  let ?M = "concat (map subterms_list (trms_listsst ?S@map (pair' tuple) (setops_listsst ?S)))"
  have "comp_tfrsst arity Ana Γ tuple ?M ?S" by eval
  thus ?thesis by (rule stm.tfrsst_if_comp_tfrsst)
qed


subsection ‹Theorem: The steps of the keyserver protocols from the ESORICS18 paper satisfy the conditions for parallel composition›
theorem
  fixes S f
  defines "S  [PK 0, invkeymsg (PK 0), Fun encodingsecret []]@concat (
                map (λs. [s, Fun tuple [PK 0, s]])
                    [validset (A 0) (A 1), beginauthset 0 (A 0) (A 1), endauthset 0 (A 0) (A 1),
                     beginauthset 1 (A 0) (A 1), endauthset 1 (A 0) (A 1)])@
                [A 0]"
    and "f  λM. {t  δ | t δ. t  M  tm.wtsubst δ  im.wftrms (subst_range δ)  fv (t  δ) = {}}"
    and "Sec  (f (set S)) - {m. im.intruder_synth {} m}"
  shows "stm.par_complsst S'ks Sec"
proof -
  let ?N = "λP. concat (map subterms_list (trms_listsst P@map (pair' tuple) (setops_listsst P)))"
  let ?M = "λl. ?N (proj_unl l S'ks)"
  have "comp_par_complsst public arity Ana Γ tuple S'ks ?M S"
    unfolding S_def by eval
  thus ?thesis
    using stm.par_complsst_if_comp_par_complsst[of S'ks ?M S]
    unfolding Sec_def f_def wftrm_def[symmetric] by blast
qed

end

Theory Example_TLS

(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Example_TLS.thy
    Author:     Andreas Viktor Hess, DTU
*)

section ‹Proving Type-Flaw Resistance of the TLS Handshake Protocol›
text ‹\label{sec:Example-TLS}›
theory Example_TLS
imports "../Typed_Model"
begin

declare [[code_timing]]

subsection ‹TLS example: Datatypes and functions setup›
datatype ex_atom = PrivKey | SymKey | PubConst | Agent | Nonce | Bot

datatype ex_fun =
  clientHello | clientKeyExchange | clientFinished
| serverHello | serverCert | serverHelloDone
| finished | changeCipher | x509 | prfun | master | pmsForm
| sign | hash | crypt | pub | concat | privkey nat
| pubconst ex_atom nat

type_synonym ex_type = "(ex_fun, ex_atom) term_type"
type_synonym ex_var = "ex_type × nat"

instance ex_atom::finite
proof
  let ?S = "UNIV::ex_atom set"
  have "?S = {PrivKey, SymKey, PubConst, Agent, Nonce, Bot}" by (auto intro: ex_atom.exhaust)
  thus "finite ?S" by (metis finite.emptyI finite.insertI) 
qed

type_synonym ex_term = "(ex_fun, ex_var) term"
type_synonym ex_terms = "(ex_fun, ex_var) terms"

primrec arity::"ex_fun  nat" where
  "arity changeCipher = 0"
| "arity clientFinished = 4"
| "arity clientHello = 5"
| "arity clientKeyExchange = 1"
| "arity concat = 5"
| "arity crypt = 2"
| "arity finished = 1"
| "arity hash = 1"
| "arity master = 3"
| "arity pmsForm = 1"
| "arity prfun = 1"
| "arity (privkey _) = 0"
| "arity pub = 1"
| "arity (pubconst _ _) = 0"
| "arity serverCert = 1"
| "arity serverHello = 5"
| "arity serverHelloDone = 0"
| "arity sign = 2"
| "arity x509 = 2"

fun public::"ex_fun  bool" where
  "public (privkey _) = False"
| "public _ = True"

fun Anacrypt::"ex_term list  (ex_term list × ex_term list)" where
  "Anacrypt [Fun pub [k],m] = ([k], [m])"
| "Anacrypt _ = ([], [])"

fun Anasign::"ex_term list  (ex_term list × ex_term list)" where
  "Anasign [k,m] = ([], [m])"
| "Anasign _ = ([], [])"

fun Ana::"ex_term  (ex_term list × ex_term list)" where
  "Ana (Fun crypt T) = Anacrypt T"
| "Ana (Fun finished T) = ([], T)"
| "Ana (Fun master T) = ([], T)"
| "Ana (Fun pmsForm T) = ([], T)"
| "Ana (Fun serverCert T) = ([], T)"
| "Ana (Fun serverHello T) = ([], T)"
| "Ana (Fun sign T) = Anasign T"
| "Ana (Fun x509 T) = ([], T)"
| "Ana _ = ([], [])"


subsection ‹TLS example: Locale interpretation›
lemma assm1:
  "Ana t = (K,M)  fvset (set K)  fv t"
  "Ana t = (K,M)  (g S'. Fun g S'  t  length S' = arity g)
                 k  set K  Fun f T'  k  length T' = arity f"
  "Ana t = (K,M)  K  []  M  []  Ana (t  δ) = (K list δ, M list δ)"
by (rule Ana.cases[of "t"], auto elim!: Anacrypt.elims Anasign.elims)+

lemma assm2: "Ana (Fun f T) = (K, M)  set M  set T"
by (rule Ana.cases[of "Fun f T"]) (auto elim!: Anacrypt.elims Anasign.elims)

lemma assm6: "0 < arity f  public f" by (cases f) simp_all

global_interpretation im: intruder_model arity public Ana
  defines wftrm = "im.wftrm"
    and wftrms = "im.wftrms"
by unfold_locales (metis assm1(1), metis assm1(2), rule Ana.simps, metis assm2, metis assm1(3))


subsection ‹TLS Example: Typing function›
definition Γv::"ex_var  ex_type" where
  "Γv v = (if (t  subterms (fst v). case t of
                (TComp f T)  arity f > 0  arity f = length T
              | _  True)
           then fst v else TAtom Bot)"

fun Γ::"ex_term  ex_type" where
  "Γ (Var v) = Γv v"
| "Γ (Fun (privkey _) _) = TAtom PrivKey"
| "Γ (Fun changeCipher _) = TAtom PubConst"
| "Γ (Fun serverHelloDone _) = TAtom PubConst"
| "Γ (Fun (pubconst τ _) _) = TAtom τ"
| "Γ (Fun f T) = TComp f (map Γ T)"


subsection ‹TLS Example: Locale interpretation (typed model)›
lemma assm7: "arity c = 0  a. X. Γ (Fun c X) = TAtom a" by (cases c) simp_all

lemma assm8: "0 < arity f  Γ (Fun f X) = TComp f (map Γ X)" by (cases f) simp_all

lemma assm9: "infinite {c. Γ (Fun c []) = TAtom a  public c}"
proof -
  let ?T = "(range (pubconst a))::ex_fun set"
  have *:
      "x y::nat. x  UNIV  y  UNIV  (pubconst a x = pubconst a y) = (x = y)"
      "x::nat. x  UNIV  pubconst a x  ?T"
      "y::ex_fun. y  ?T  x  UNIV. y = pubconst a x"
    by auto
  have "?T  {c. Γ (Fun c []) = TAtom a  public c}" by auto
  moreover have "f::nat  ex_fun. bij_betw f UNIV ?T"
    using bij_betwI'[OF *] by blast
  hence "infinite ?T" by (metis nat_not_finite bij_betw_finite)
  ultimately show ?thesis using infinite_super by blast
qed

lemma assm10: "TComp f T  Γ t  arity f > 0"
proof (induction rule: Γ.induct)
  case (1 x)
  hence *: "TComp f T  Γv x" by simp
  hence v x  TAtom Bot" unfolding Γv_def by force
  hence "t  subterms (fst x). case t of
                (TComp f T)  arity f > 0  arity f = length T
              | _  True"
    unfolding Γv_def by argo
  thus ?case using * unfolding Γv_def by fastforce 
qed auto

lemma assm11: "im.wftrm (Γ (Var x))"
proof -
  have "im.wftrm (Γv x)" unfolding Γv_def im.wftrm_def by auto 
  thus ?thesis by simp
qed

lemma assm12: (Var (τ, n)) = Γ (Var (τ, m))"
  apply (cases "t  subterms τ. case t of
                (TComp f T)  arity f > 0  arity f = length T
              | _  True")
  by (auto simp add: Γv_def)

lemma Ana_const: "arity c = 0  Ana (Fun c T) = ([],[])"
by (cases c) simp_all

lemma Ana_keys_subterm: "Ana t = (K,T)  k  set K  k  t"
proof (induct t rule: Ana.induct)
  case (1 U)
  then obtain m where "U = [Fun pub [k], m]" "K = [k]" "T = [m]"
    by (auto elim!: Anacrypt.elims Anasign.elims)
  thus ?case using Fun_subterm_inside_params[of k crypt U] by auto
qed (auto elim!: Anacrypt.elims Anasign.elims)

global_interpretation tm: typed_model' arity public Ana Γ
by (unfold_locales, unfold wftrm_def[symmetric],
    metis assm7, metis assm8, metis assm9, metis assm10, metis assm11, metis assm6,
    metis assm12, metis Ana_const, metis Ana_keys_subterm)

subsection ‹TLS example: Proving type-flaw resistance›
abbreviation Γv_clientHello where
  "Γv_clientHello 
    TComp clientHello [TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce]"

abbreviation Γv_serverHello where
  "Γv_serverHello 
    TComp serverHello [TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce]"

abbreviation Γv_pub where
  "Γv_pub  TComp pub [TAtom PrivKey]"

abbreviation Γv_x509 where
  "Γv_x509  TComp x509 [TAtom Agent, Γv_pub]"

abbreviation Γv_sign where
  "Γv_sign  TComp sign [TAtom PrivKey, Γv_x509]"

abbreviation Γv_serverCert where
  "Γv_serverCert  TComp serverCert [Γv_sign]"

abbreviation Γv_pmsForm where
  "Γv_pmsForm  TComp pmsForm [TAtom SymKey]"

abbreviation Γv_crypt where
  "Γv_crypt  TComp crypt [Γv_pub, Γv_pmsForm]"

abbreviation Γv_clientKeyExchange where
  "Γv_clientKeyExchange 
    TComp clientKeyExchange [Γv_crypt]"

abbreviation Γv_HSMsgs where
  "Γv_HSMsgs  TComp concat [
    Γv_clientHello,
    Γv_serverHello,
    Γv_serverCert,
    TAtom PubConst,
    Γv_clientKeyExchange]"

(* Variables from TLS *)
abbreviation "T1 n  Var (TAtom Nonce,n)"
abbreviation "T2 n  Var (TAtom Nonce,n)"
abbreviation "RA n  Var (TAtom Nonce,n)"
abbreviation "RB n  Var (TAtom Nonce,n)"
abbreviation "S n  Var (TAtom Nonce,n)"
abbreviation "Cipher n  Var (TAtom Nonce,n)"
abbreviation "Comp n  Var (TAtom Nonce,n)"
abbreviation "B n  Var (TAtom Agent,n)"
abbreviation "Prca n  Var (TAtom PrivKey,n)"
abbreviation "PMS n  Var (TAtom SymKey,n)"
abbreviation "PB n  Var (TComp pub [TAtom PrivKey],n)"
abbreviation "HSMsgs n  Var (Γv_HSMsgs,n)"

subsubsection ‹Defining the over-approximation set›
abbreviation clientHellotrm where
  "clientHellotrm  Fun clientHello [T1 0, RA 1, S 2, Cipher 3, Comp 4]"

abbreviation serverHellotrm where
  "serverHellotrm  Fun serverHello [T2 0, RB 1, S 2, Cipher 3, Comp 4]"

abbreviation serverCerttrm where
  "serverCerttrm  Fun serverCert [Fun sign [Prca 0, Fun x509 [B 1, PB 2]]]"

abbreviation serverHelloDonetrm where
  "serverHelloDonetrm  Fun serverHelloDone []"

abbreviation clientKeyExchangetrm where
  "clientKeyExchangetrm  Fun clientKeyExchange [Fun crypt [PB 0, Fun pmsForm [PMS 1]]]"

abbreviation changeCiphertrm where
  "changeCiphertrm  Fun changeCipher []"

abbreviation finishedtrm where
  "finishedtrm  Fun finished [Fun prfun [
      Fun clientFinished [
          Fun prfun [Fun master [PMS 0, RA 1, RB 2]],
          RA 3, RB 4, Fun hash [HSMsgs 5]
      ]
  ]]"

definition MTLS::"ex_term list" where
  "MTLS  [
    clientHellotrm,
    serverHellotrm,
    serverCerttrm,
    serverHelloDonetrm,
    clientKeyExchangetrm,
    changeCiphertrm,
    finishedtrm
]"


subsection ‹Theorem: The TLS handshake protocol is type-flaw resistant›
theorem "tm.tfrset (set MTLS)"
by (rule tm.tfrset_if_comp_tfrset') eval

end

Theory Examples

theory Examples
  imports "examples/Example_Keyserver"
          "examples/Example_TLS"
begin
end